CHANGER L'ICONE D'UNE FORM, LIVRÉ AVEC ICONS ET SOURCES, MARCHE TRÈS BIEN!!!

Commentaire de DedeSurf le 23/12/2007 00:19:27

Option Explicit

Public Declare Function ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" (ByVal hInst As Long, ByVal lpIconPath As String, lpiIcon As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1
Public Declare Function ReleaseCapture Lib "user32" () As Long ' et de la relacher

' déclaration pour fonction TransRegion

Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000

Public Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long

Private Declare Function GetWindowLong Lib "user32" _
  Alias "GetWindowLongA" (ByVal hWnd As Long, _
  ByVal nIndex As Long) As Long

Private Declare Function SetWindowLong Lib "user32" _
   Alias "SetWindowLongA" (ByVal hWnd As Long, _
   ByVal nIndex As Long, ByVal dwNewLong As Long) _
   As Long

Private Declare Function SetLayeredWindowAttributes Lib _
    "user32" (ByVal hWnd As Long, ByVal crKey As Long, _
    ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

Public Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
' Structure contenant des infos sur une image
Public Type PICTDESC
    ' Normalement cette structure contient une union mais VB ne les gère pas
    cbSizeofStruct As Long      ' Taille de cette structure
    picType As Long             ' Type d'image : ICON, BITMAP, METAFILE, ENHMETAFILE
    ' Début union
        hImage As Long          ' Handle de l'image
        xExt As Long            ' Taille x de l'image pour une METAFILE
        yExt As Long            ' Taille y de l'image pour une METAFILE
End Type
' picType de PICTDESC pour une ICON
Public Const PICTYPE_ICON = 3
'permet de convertir une structure PICTDESC (et donc un handle d'image) en un IPictureDisp (= StdPicture)
Public Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" (ByRef lpPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef lplpvObj As IPictureDisp)

Public Function GetIcon(ByVal Path As String) As IPictureDisp
Dim  hIco As Long
hIco = ExtractAssociatedIcon(0, Path, 0)
Set GetIcon = GetIconFromHandle(hIco)
End Function

Public Function GetIconFromHandle(hIcon As Long) As IPictureDisp
    ' Le REFIID de IPictureDisp (=GUID)
    Dim IID_IPictureDisp As GUID
    ' Infos sur l'icone
    Dim lpIcon As PICTDESC
    'on met place l'IID de IPictureDisp
    IID_IPictureDisp.Data1 = &H7BF80981
    IID_IPictureDisp.Data2 = &HBF32
    IID_IPictureDisp.Data3 = &H101A
    IID_IPictureDisp.Data4(0) = &H8B
    IID_IPictureDisp.Data4(1) = &HBB
    IID_IPictureDisp.Data4(2) = &H0
    IID_IPictureDisp.Data4(3) = &HAA
    IID_IPictureDisp.Data4(4) = &H0
    IID_IPictureDisp.Data4(5) = &H30
    IID_IPictureDisp.Data4(6) = &HC
    IID_IPictureDisp.Data4(7) = &HAB
    ' On initialise les champs requis :
    lpIcon.cbSizeofStruct = Len(lpIcon)
    lpIcon.hImage = hIcon
    ' le type : ICON
    lpIcon.picType = PICTYPE_ICON
    'on demande la création d'une interface de type IPictureDisp pour le handle d'icône
    'et en indiquant de ne pas effacer le HICON quand l'interface est libéré
    OleCreatePictureIndirect lpIcon, IID_IPictureDisp, 0, GetIconFromHandle
End Function

public sub form_load()
   icon = geticon("bla bla/n")
end sub

Voila le tours est joué l'icone encore une fois n'est pas de très bonne qualité mais y a la transparence ! deplus les déclarations sont soit dans un module soit elle sont privées

Je t'ai collé une icone dans les règle de l'art !

++