Creation de form par api

Commenter

Contenu du snippet

Le code créer simplement une fenetre a l'aide des API.
Il faut mettre le code dans un module

Vous n'avez pas besoin de form principale
le module suffit.

SVP Laissez les copyright , soyez respectueux du travail des gens SVP

Source / Exemple : 


'*----------------------------------------
'* Génération de fenetre a l'aide d'api  
'*                                                     
'*  Copyright vbapihelpline                  
'*  Update , traduction et adaptation    
'*  TheSaib pour Codes-sources.com       
'*              18/12/02                 
'* Laissez les copyright dans vos softs  
'* Le copiage sans copyright tue le developpements 
'* amateur
'*----------------------------------------

Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function RegisterClass Lib "user32.dll" Alias "RegisterClassA" (lpWndClass As WNDCLASS) As Long
Private Declare Function UnregisterClass Lib "user32.dll" Alias "UnregisterClassA" (ByVal lpClassName As Any, ByVal hInstance As Long) As Long
Private Declare Function DefWindowProc Lib "user32.dll" Alias "DefWindowProcA" (ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 
Private Type WNDCLASS
   style As Long
   lpfnWndProc As Long
   cbClsExtra As Long
   cbWndExtra As Long
   hInstance As Long
   hIcon As Long
   hCursor As Long
   hbrBackground As Long
   lpszMenuName As String
   lpszClassName As String
End Type
 
'constante dwExStyle
Private Const WS_EX_ACCEPTFILES = &H10 'Drag and Drop possible
Private Const WS_EX_CONTEXTHELP = &H400 '? dans la titleBar
Private Const WS_EX_CONTROLPARENT = &H10000 'La fenetre peut avoir des enfants
Private Const WS_EX_DLGMODALFRAME = &H1 'La fenetre est une frame modale
Private Const WS_EX_LEFT = &H0 'Alignement a gauche de la fenetre
Private Const WS_EX_LEFTSCROLLBAR = &H4000 'La scrollbar a gauche
Private Const WS_EX_LTRREADING = &H0 'La lecture du texte se fait de Gauche a droite
Private Const WS_EX_MDICHILD = &H40 'La fenetre est une fenetre enfantée
Private Const WS_EX_NOACTIVATE = &H8000000 '(Win 2000) La fenetre ne peut etre activée
Private Const WS_EX_NOPARENTNOTIFY = &H4 'La fenetre n'est pas detruite par sa parente
Private Const WS_EX_OVERLAPPEDWINDOW = &H300 '?
Private Const WS_EX_PALETTEWINDOW = &H188 '?
Private Const WS_EX_RIGHT = &H1000 'Aligenement a droite de la fenetre
Private Const WS_EX_RIGHTSCROLLBAR = &H0 'Ya des scrollbars a droite
Private Const WS_EX_RTLREADING = &H2000 'Lecture de droite a gauche du texte possible
Private Const WS_EX_STATICEDGE = &H20000 'RElatif aux objets 3D de la form
Private Const WS_EX_TOOLWINDOW = &H80 'c une toolwindow
Private Const WS_EX_TOPMOST = &H8 'La fenetre est toujorus visible
Private Const WS_EX_TRANSPARENT = &H20 'La fenetre est transparente
Private Const WS_EX_WINDOWEDGE = &H100 'Bords de la fenetre sizable
 
'dwStyle Konstanten
Private Const WS_BORDER = &H800000 'La fenetre a des bordures
Private Const WS_CAPTION = &HC00000 'La fenetre a un titre
Private Const WS_CHILD = &H40000000 'LA fenetre est une enfant
Private Const WS_CLIPCHILDREN = &H2000000 'Les fenetres enfants ne regourpent pas la fenetre mère
Private Const WS_CLIPSIBLINGS = &H4000000 'Les fenetres enfants ne regourpent pas la fenetre mère
Private Const WS_DISABLED = &H8000000 'La fenetre est désactivée
Private Const WS_DLGFRAME = &H400000 'TitleBar et c une boite de dialogue
Private Const WS_GROUP = &H20000 'Rassemblage de toutes les fenetres et boutons de commande dans un groupe
Private Const WS_HSCROLL = &H100000 'La fenetre a des scrollbars horizontaux
Private Const WS_MAXIMIZE = &H1000000 'La fenetre est maximisée
Private Const WS_MAXIMIZEBOX = &H10000 'Symbole 'Maximiser'
Private Const WS_MINIMIZE = &H20000000 'La fenetre est réduite
Private Const WS_MINIMIZEBOX = &H20000 'Symbole 'minimiser'
Private Const WS_OVERLAPPED = &H0 'TitleBAr et X
Private Const WS_OVERLAPPEDWINDOW = &HCF0000 'La fenetre a des clipcontrols (-OX)
Private Const WS_POPUP = &H80000000 'Mode popup
Private Const WS_POPUPWINDOW = &H80880000 'Mode popup (toolbox)
Private Const WS_SIZEBOX = &H40000 'La fenetre peut etre redimenssionner
Private Const WS_SYSMENU = &H80000 'La fenetre a une barre de titre
Private Const WS_TABSTOP = &H10000 'La fenetre est réactive au tab
Private Const WS_VISIBLE = &H10000000 'La fenetre est visible
Private Const WS_VSCROLL = &H200000 'La fenetre a un scrollbar vertical
 
'Autres Constantes
Private Const CW_USEDEFAULT = &H80000000
 
'Constante hWndParent
Private Const HWND_BROADCAST = &HFFFF
 
'Cosntante WNDCLASS.style
Private Const CS_BYTEALIGNCLIENT = &H1000 'Alignement en fonction des bits de limitations ?
Private Const CS_BYTEALIGNWINDOW = &H2000 'Orientation de la fenetre
Private Const CS_CLASSDC = &H40 'Toutes les fenêtres de cette classe ont les mêmes Contexte
Private Const CS_DBLCLKS = &H8 'double click sur la fenetre
Private Const CS_HREDRAW = &H2 'Lors de changement d'attributs de la frame (taille position ...) Redessinage de la fenetre (partie horizontale)
Private Const CS_NOCLOSE = &H200 'Désactivation du close
Private Const CS_OWNDC = &H20 'Chaque fenêtre qui est dérivée de cette classe obtient son propre contexte
Private Const CS_PARENTDC = &H80 'Permet à la fenetre d'etre dessiné sur sa parente
Private Const CS_SAVEBITS = &H800 'Conservation des infos de la fenetre (+ou-)
Private Const CS_VREDRAW = &H1 'Lors de changement d'attributs de la frame (taille position ...) Redessinage de la fenetre (partie verticale)
 
'Cosntantes WNDCLASS.hbrBackground
Private Const COLOR_ACTIVEBORDER = 10 'couleur des bordure en mode activé  (Focusé)
Private Const COLOR_ACTIVECAPTION = 2 'Couleur de mode activé
Private Const COLOR_APPWORKSPACE = 12 'Couleur de la zone de travail
Private Const COLOR_BACKGROUND = 1 'Couleur du fond de la fenetre
Private Const COLOR_BTNFACE = 15 'Couleur du bouton (face)
Private Const COLOR_BTNHIGHLIGHT = 20 'Couleur du bont surligné (on passe dessus)
Private Const COLOR_BTNSHADOW = 16 'Couleurs de l'ombre d'un bouton
Private Const COLOR_BTNTEXT = 18 'Couleur des textes sur les bouttons
Private Const COLOR_CAPTIONTEXT = 9 'Couleur du texte actifs
Private Const COLOR_GRAYTEXT = 17 'SCouleur du texte inactif
Private Const COLOR_HIGHLIGHT = 13
Private Const COLOR_HIGHLIGHTTEXT = 14 'couleur du texte surligné
Private Const COLOR_INACTIVEBORDER = 11 'Couleur des bordures inactives
Private Const COLOR_INACTIVECAPTION = 3 'Couleur du titre de la fenetre inactive
Private Const COLOR_INACTIVECAPTIONTEXT = 19 'Couleur standard d'un texte de bord de titre inactif
Private Const COLOR_MENU = 4 'Couleur des menus
Private Const COLOR_MENUTEXT = 7 'Couleur des textes des menus
Private Const COLOR_SCROLLBAR = 0 'Couleurs des scrolls
Private Const COLOR_WINDOW = 5 'Couleur de la fenetre
Private Const COLOR_WINDOWFRAME = 6 'Couleur de la frame
Private Const COLOR_WINDOWTEXT = 8 'Couleur du texte de la fenetre
 
'Info de la fenerte
Private Const WM_DESTROY = &H2 'Fenetre detruite
Private Const WM_MOVE = &H3 'Décalage de la fenetre
Private Const WM_SIZE = &H5 'Changement de taille de la fenetre
Private Const WM_LBUTTONDBLCLK = &H203 'Fenetre doublecliquée
 
Private WindowClose As Boolean
 

'Procedure principale de la fenetre tous les messages passent par cette fonctions
Public Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
   Dim HIWORD As Long, LOWORD As Long
   
   'Test des messages
   'routine liées aux messages
   Select Case uMsg
   Case WM_DESTROY
      Debug.Print "Fermeture de l'application"
      WindowClose = True
   Case WM_SIZE
      HIWORD = CLng("&H" & Left(Right("00000000" & Hex(lParam), 8), 4)) - 24 'Bit de poids fort
      LOWORD = CLng("&H" & Right(Right("00000000" & Hex(lParam), 8), 4)) - 4 'Bit de poids faible
      Debug.Print "Modification de la taille de la fenetre : (x=" & HIWORD & ",y=" & LOWORD & ")"
   Case WM_MOVE
      HIWORD = CLng("&H" & Left(Right("00000000" & Hex(lParam), 8), 4)) - 24
      LOWORD = CLng("&H" & Right(Right("00000000" & Hex(lParam), 8), 4)) - 4
      Debug.Print "Deplacement de la fenetre : (x=" & HIWORD & ",y=" & LOWORD & ")"
   Case WM_LBUTTONDBLCLK
      Debug.Print "DoubleClick sur la fenetre."
   End Select
   
   'Procédure standard de définition de fonction principale
   WindowProc = DefWindowProc(hWnd, uMsg, wParam, lParam)
End Function
 
'Permet de recuperre l'adresse de la fenetre principele
Private Function GetFuncAddress(ByVal Address As Long) As Long
   GetFuncAddress = Address
End Function
 

Sub Main()
   Dim OwnClass As WNDCLASS, hWnd As Long
   Dim ClassAtom As Long
   
   'Attributs de la classe
   With OwnClass
      .style = CS_OWNDC Or CS_HREDRAW Or CS_VREDRAW
      .lpfnWndProc = GetFuncAddress(AddressOf WindowProc)
      .hInstance = App.hInstance
      .lpszClassName = "Classe_Principale"
      .hbrBackground = COLOR_APPWORKSPACE
   End With
   
   'Enregistrement de la classe
   ClassAtom = RegisterClass(OwnClass)
   If ClassAtom = 0 Then
      MsgBox "Enregistrement de la classe impossible.", vbInformation, "Erreur"
      End
   End If
   
   'Création de la fenetre
   Dim NormalStyles As Long
   Dim xPos As Long, yPos As Long
   NormalStyles = WS_OVERLAPPEDWINDOW Or WS_CAPTION Or WS_BORDER Or WS_VISIBLE 'Attributs de la fenetre
   xPos = (Screen.Width / Screen.TwipsPerPixelX - 320) / 2 'Position Horizontale
   yPos = (Screen.Height / Screen.TwipsPerPixelY - 200) / 2 'Position Verticlae
   hWnd = CreateWindowEx(WS_EX_APPWINDOW, "Classe_Principale", "TheSaib Form Création", NormalStyles, xPos, yPos, 320&, 200&, 0&, 0&, App.hInstance, ByVal 0&)
   
   If hWnd = 0 Then
      MsgBox "Creation de la classe impossible", vbInformation, "Erreur"
      GoTo UnregisterClass
      End
   End If
   
   'Fermeture de la fenetre quand le message close est envoyée
   Do
      DoEvents
   Loop While WindowClose = False
   
   'Désenregistrement de la classe
UnregisterClass:
   Retval = UnregisterClass("Classe_Principale", App.hInstance)
   If Retval = 0 Then
      MsgBox "Unregistrer de la classe impossible", vbCritical, "Erreur"
   End If
End Sub

Conclusion :


Ce n'est pas trop compliqué , des explications peuvent etre mal dites, veuillez m'en escuser

TheSaib

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (TheSaib)