Menu
Donnez votre avis

Déplacer, avec la souris, un UserForm sans barre de fenêtre

Posez votre question



Pré-requis

Pour cet exemple, nous avons besoin :
  • D'un Userform nommé UserForm1,
  • Sur cet UserForm, un bouton de commande : CommandButton1.

Présentation

Cet UserForm sera présenté sans barre de fenêtre (cf Sub Masque_Barre) et pourra être déplacé manuellement en maintenant la touche Shift et le clic gauche de la souris enfoncés simultanément (cf Sub DeplaceForm et événement UserForm_MouseDown).

Code

Le code, à placer dans le module de l'UserForm, est :

Option Explicit
 
Private LeHwnD As Long
 
'=================== Evénements
Private Sub CommandButton1_Click()
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    Masque_Barre Me.Caption
End Sub
 
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'permet le déplacement de l'Userform par la combinaison Shift + clic gauche
    If Button = 1 And Shift = 1 Then DeplaceForm
End Sub
 
'=================== Procédures
Public Sub Masque_Barre(strCapt As String)
Dim style As Long, index As Long
 
    index = -16
    LeHwnD = FindWindo("ThunderDFrame", strCapt)
    style = GetWindoLong(LeHwnD, index) And Not &HC00000
    SetWindoLong LeHwnD, index, style
    DrawMenuB LeHwnD
End Sub
 
'=================== Utilisations des fonctions de l'api
Public Sub DeplaceForm()
'ReleaseCapture & SendMessageA
'https://www.developpez.net/forums/d1517529/autres-langages/general-visual-basic-6-vbscript/vbscript/vos-contributions-vbscript/hta-deplacer-hta-n-barre-titre-bordures/
    ExecuteExcel4Macro "CALL(""user32"",""ReleaseCapture"",""JJ"")"
    ExecuteExcel4Macro "CALL(""user32"",""SendMessageA"",""JJJJJ"",""" & LeHwnD & """,""" & &HA1 & """,""" & &O2 & """,""0"")"
End Sub
 
Private Function FindWindo(ClassName As String, Caption As String) As Long
'FindWindowA
    FindWindo = ExecuteExcel4Macro("CALL(""user32"",""FindWindowA"",""JCC""," & """" & ClassName & """" & ", " & """" & Caption & """)")
End Function
 
Private Function GetWindoLong(ByVal hwnd As Long, ByVal nIndex As Long) As Long
'GetWindowLongA
    GetWindoLong = ExecuteExcel4Macro("CALL(""user32"",""GetWindowLongA"",""JCA""," & hwnd & ", " & nIndex & ")")
End Function
 
Private Sub SetWindoLong(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long)
'SetWindowLongA
    ExecuteExcel4Macro ("CALL(""user32"",""SetWindowLongA"",""JJJJJ""," & hwnd & ", " & nIndex & ", " & dwNewLong & ")")
End Sub
 
Private Sub DrawMenuB(H As Long)
'DrawMenuBar
    ExecuteExcel4Macro ("CALL(""user32"",""DrawMenuBar"",""JJ"", " & H & ")")
End Sub

Conclusion/Téléchargement

Voyez cette contribution comme la présentation d'une possibilité offerte par la Méthode ExecuteExcel4Macro.

Fichier à télécharger : http://www.cjoint.com/c/GIgipHGcwOE
Ajouter un commentaire

Commentaires

Commenter la réponse de Utilisateur anonyme
VBA Mon second UserForm - Création d'un QCM
VBA Fonction déterminant si un mot peut-être épelé avec une collection de lettres