Combiné deux fonction dans un userform

Le 02/07/2017 à 20:09

Bien le bonjour,

Vola j'ai deux fonctions (qui ne sont pas de moi) que je voudrai mettre sur un UserFom

La première pour mettre un icone sur la barre de titre

La seconde pour ôter la croix pour fermer l'UserForm

Le problème est quand je met la seconde ça masque l'icone de la première donc je voudrai quelqu'un pour m'aider à mettre ces deux fonctions sur mon UserForm.

Option Explicit
'#Function pour ajouter un icone a la barre de titre
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
      (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function SendMessageA Lib "user32" _
      (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, _
      ByVal lParam As Long) As Long
Private Declare PtrSafe Function ExtractIconA Lib "shell32.dll" _
      (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
'#Fin Function pour ajouter un icone a la barre de titre
'#Function pour masquer la croix
Private Declare PtrSafe Function GetWindowLongA Lib "user32" _
    (ByVal hwndd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLongA Lib "user32" _
    (ByVal hwndd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function FindWindowA Lib "user32" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'#Fin de la function masquer la croix

'#Fin#
Private Sub UserForm_Initialize()
    Dim Fichier As String
    Dim x As Long
    OteCroix Me.Caption
    'Chemin et nom du fichier icône à afficher
    Fichier = "C:\Camping\IconeApp.ICO"
    'Vérifie si le fichier existe
    If Dir(Fichier) = "" Then Exit Sub

    x = ExtractIconA(0, Fichier, 0)
    SendMessageA FindWindow(vbNullString, Me.Caption), &H80, False, x

End Sub

'#Sub#
Private Sub OteCroix(Caption As String)
Dim hwnd As Long
   hwnd = FindWindowA("Thunder" & IIf(Application.Version Like "8*", "X", "D") _
    & "Frame", Caption)
    SetWindowLongA hwnd, -16, GetWindowLongA(hwnd, -16) And &HFFF7FFFF
End Sub

merci a vous

Le 02/07/2017 à 22:37

Bonjour Don Pépé, bonjour le forum

Des bouts de code pioché sur le Net.

Penser à mettre un bouton pour fermer.

Option Explicit

        '#Function pour ajouter un icone a la barre de titre
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

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

Private Declare PtrSafe Function ExtractIconA Lib "shell32.dll" _
    (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
         '#Fin Function pour ajouter un icone a la barre de titre

Private Declare Function SetWindowLong& Lib "user32" Alias _
    "SetWindowLongA" (ByVal hwnd&, ByVal nIndex&, ByVal dwNewLong&)

Private Declare Function ExtractIcon& Lib "shell32.dll" _
    Alias "ExtractIconA" (ByVal hInst&, ByVal lpszExeFileName$, ByVal nIconIndex&)

Private Declare Function SendMessage& Lib "user32" Alias _
    "SendMessageA" (ByVal hwnd&, ByVal wMsg&, ByVal wParam%, ByVal lParam As Any)

Private Declare Function GetSystemMenu& Lib "user32" _
    (ByVal hwnd&, ByVal bRevert&)

Private Declare Function DrawMenuBar& Lib "user32" (ByVal hwnd&)

Private Declare Function DeleteMenu& Lib "user32" _
    (ByVal hMenu&, ByVal nPosition&, ByVal wFlags&)

Private Sub UserForm_Initialize()
Dim hwnd&, IcoPath$, hIcon&
Dim Fichier As String
Dim x As Long

hwnd = FindWindow(vbNullString, Me.Caption)
IcoPath = ThisWorkbook.Path & "msn.ico"
If Len(Dir(IcoPath)) Then
    hIcon = ExtractIcon(0, IcoPath, 0)
    SendMessage hwnd, &H80, 0, hIcon
End If
DeleteMenu GetSystemMenu(hwnd, 0), &HF060, 0&
DrawMenuBar hwnd

        'Chemin et nom du fichier icône à afficher
Fichier = "C:\Camping\IconeApp.ICO"
        'Vérifie si le fichier existe
If Dir(Fichier) = "" Then Exit Sub
x = ExtractIconA(0, Fichier, 0)
SendMessageA FindWindow(vbNullString, Me.Caption), &H80, False, x

End Sub

Private Sub CommandButton1_Click()
End
End Sub

Joseph

Le 03/07/2017 à 10:57