Este fórum está sendo desativado

Depois de 9 anos, este fórum será desativado. Mas calma.... estamos migrando para uma comunidade no DISCORD. Junte-se a nós.

ENTRAR PARA DISCORD

Tópicos relacionados a códigos VBA, gravação de macros, etc.
  • Avatar do usuário
Por UngerSantos
Posts
#20892
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
Avatar do usuário
Por alexandrevba
Avatar
#20903
Boa noite!!

Favor ler as regras do fórum!!!
viewtopic.php?f=5&t=4
Regra nº 11:
Nós preferimos que os membros não façam postagens cruzadas (quando a mesma postagem é feita em diferentes fóruns). Mas quando isso ocorrer, os membros devem deixar claro os links para as postagens cruzadas.
Favor indicar as postagens cruzadas:
http://www.planilhando.com.br/forum/vie ... 10&t=23829
http://www.planilhando.com.br/forum/vie ... 10&t=23832


Att
Por UngerSantos
Posts
#20916
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.
Abraços
João Santos
long long title how many chars? lets see 123 ok more? yes 60

We have created lots of YouTube videos just so you can achieve [...]

Another post test yes yes yes or no, maybe ni? :-/

The best flat phpBB theme around. Period. Fine craftmanship and [...]

Do you need a super MOD? Well here it is. chew on this

All you need is right here. Content tag, SEO, listing, Pizza and spaghetti [...]

Lasagna on me this time ok? I got plenty of cash

this should be fantastic. but what about links,images, bbcodes etc etc? [...]

Estamos migrando para uma comunidade no Discord