Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Alterar o Icon do E...
 
Notifications
Clear all

Alterar o Icon do Excel

 
2024 - VBA & Macros
Post Recente por ungsantos 8 anos atrás
2 Posts
1 Usuários
0 Reactions
673 Visualizações
RSS
 ungsantos
(@ungsantos)
Posts: 0
New Member
Topic starter
 

Este código corre bem em sistemas de 64 e 32, somente altera o icon pequeno no excel e o grande nao altera, somente no meu office 2010. Quando corro em outro office 2013 ou 2007 nao altera o Icon grande, será que alguém poderá ajudar
Abraços
Joao Santos

Option Explicit

#If Win64 Then

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Public Declare PtrSafe Function SendMessageA Lib "user32" (ByVal hWnd As LongPtr, ByVal wMsg As Long, _
ByVal wParam As LongPtr, lParam As Any) As LongPtr

Private Declare PtrSafe Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" _
(ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long

                                                           
#Else


Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" _
(ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

#End If

Private Const WM_SETICON = &H80
Private Const ICON_SMALL = 0
Private Const ICON_BIG = 1

Sub setExcelIcon(Optional stFileName As String = "", Optional strIconIndex As Long = 0, Optional bSetBigIcon As Boolean = False, Optional bSetSmallIcon As Boolean = True)

Dim hIcon As Long
Dim hwndXLApp As Long


On Error Resume Next

hwndXLApp = FindWindow("XLMAIN", Application.Caption)

If hwndXLApp <> 0 Then

Err.Clear

If stFileName = "" Then

strIconIndex = 8000

hIcon = ExtractIcon(0, Application.Path & Application.PathSeparator & "Excel.exe", strIconIndex)

ElseIf Dir(stFileName) = "" Then

hIcon = 0

ElseIf Err.Number <> 0 Then

hIcon = 0

Else

hIcon = ExtractIcon(0, stFileName, strIconIndex)

End If

If bSetBigIcon Then SendMessage hwndXLApp, WM_SETICON, ICON_BIG, hIcon

If bSetSmallIcon Then SendMessage hwndXLApp, WM_SETICON, ICON_SMALL, hIcon

End If
End Sub


Sub Change_Icon_1()
setExcelIcon ThisWorkbook.Path &Logo_Icon_RED.ico"
End Sub

Sub Reset_Icons()
setExcelIcon ""
End Sub
 
Postado : 06/03/2017 8:45 am
 ungsantos
(@ungsantos)
Posts: 0
New Member
Topic starter
 

Bom depois de algum pensamento aqui encontrei a solução:

Adicionei estes campos:

SendMessage GetWindow(hwndIcon, GW_OWNER), WM_SETICON, ICON_SMALL, hwndIcon
SendMessage GetWindow(hwndIcon, GW_OWNER), WM_SETICON, ICON_BIG, hwndIcon

mais os outros dois acima

e alterei o option Explicit para :

Option Explicit

'Declaring the necessary API functions and constants.
#If VBA7 And Win64 Then

'For 64 bit Excel.
Private Declare PtrSafe Function ExtractIconA Lib "shell32.dll" _
(ByVal hInst As LongPtr, _
ByVal lpszExeFileName As String, _
ByVal nIconIndex As Long) As LongPtr

Private Declare PtrSafe Function SendMessageA Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As LongPtr

Private Declare PtrSafe Function GetWindow _
Lib "user32.dll" Alias "GetWindowLongPtrA" ( _
ByVal hwndIcon As LongPtr, _
ByVal nIndex As Long) As LongPtr

Private Const ICON_SMALL As LongPtr = 0&
Private Const ICON_BIG As LongPtr = 1&
Dim hwndIcon As LongPtr

#Else

'For 32 bit Excel.
Private Declare Function ExtractIconA Lib "shell32.dll" _
(ByVal hInst As Long, _
ByVal lpszExeFileName As String, _
ByVal nIconIndex As Long) As Long

Private Declare Function SendMessageA Lib "user32" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long

Private Declare Function GetWindow _
Lib "user32.dll" Alias "GetWindowLongA" ( _
ByVal hwndIcon As Long, _
ByVal nIndex As Long) As Long

Private Const WM_SETICON As Long = &H80
Private Const ICON_SMALL As Long = 0&
Private Const ICON_BIG As Long = 1&
Private Const GW_OWNER = 2
Dim hwndIcon As Long

Obrigado a todos os que participaram, da próxima vez coloco o link à resposta.
respondi também para : https://gurudoexcel.com/forum/viewtopic ... 916#p20916
Abraços
João Santos

 
Postado : 07/03/2017 1:33 am
Forum Jump:
  Tópico Anterior
Próximo Tópico