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

Novembre 2017




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

Publié par pijaku.
Ce document intitulé «  Déplacer, avec la souris, un UserForm sans barre de fenêtre  » issu de CommentCaMarche (www.commentcamarche.net) est mis à disposition sous les termes de la licence Creative Commons. Vous pouvez copier, modifier des copies de cette page, dans les conditions fixées par la licence, tant que cette note apparaît clairement.