Quelques trucs utiles pour vos menus et sous menus

Télécharger le projet
Commenter

Description

voici comment ajouter des menus soujassant et meme remolacer ceux de base des apllications compilées avec vb5 , vb6 (ca devait aussi marcher avec vb4 mais je ne l'ai pas testé ne l'ayant )
aussi deus fonctions assez cool pour ecrire et lire les .ini
un get AppINI simple mais efficace

Source / Exemple : 


'dans le module
Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hWnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As IconeTray) As Boolean
Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Type SHITEMID
    cb As Long
    abID As Byte
End Type
Type ITEMIDLIST
    mkid As SHITEMID
End Type
Type IconeTray
cbSize As Long
hWnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Const message = &H1
Const Icone = &H2
Const TIP = &H4
'tirés du C++
Const CSIDL_DESKTOP = &H0
Const CSIDL_PERSONAL = &H5
Const MAX_PATH = 260
Const MC_ADD = &H0
Const MC_CHANGE = &H1
Const MC_REMOVE = &H2
Const MOUSEMOVE = &H200
Const MTS_LEFTCLICK = &H203
Const MTS_LEFTDOWN = &H201
Const MTS_LEFTUP = &H202
Const MTS_RIGHTCLICK = &H206
Const MTS_RIGHTDOWN = &H204
Const MTS_RIGHTUP = &H205
Const SC_SIZE = &HF000
Const SC_MOVE = &HF010
Const SC_MINIMIZE = &HF020
Const SC_MAXIMIZE = &HF030
Const SC_NEXTWINDOW = &HF040
Const SC_PREVWINDOW = &HF050
Const SC_CLOSE = &HF060
Const SC_VSCROLL = &HF070
Const SC_HSCROLL = &HF080
Const SC_MOUSEMENU = &HF090
Const SC_KEYMENU = &HF100
Const SC_ARRANGE = &HF110
Const SC_RESTORE = &HF120
Const SC_TASKLIST = &HF130
Const SC_SCREENSAVE = &HF140
Const SC_HOTKEY = &HF150
Const SC_DEFAULT = &HF160
Const SC_MONITORPOWER = &HF170
Const SC_CONTEXTHELP = &HF180
Const SC_SEPARATOR = &HF00F
Const MF_BYPOSITION = &H400&
Const MF_REMOVE = &H1000&
Const WM_SYSCOMMAND = &H112
Const MF_SEPARATOR = &H800&
Const MF_STRING = &H0&
Const MF_INSERT = &H0
Const MF_CHANGE = &H80
Const MF_APPEND = &H100
Const MF_DELETE = &H200
Const MF_BYCOMMAND = &H0
Const MF_ENABLED = &H0
Const MF_GRAYED = &H1
Const MF_DISABLED = &H2
Const MF_UNCHECKED = &H0
Const MF_CHECKED = &H8
Const MF_USECHECKBITMAPS = &H200
Const MF_BITMAP = &H4
Const MF_OWNERDRAW = &H100
Const MF_POPUP = &H10
Const MF_MENUBARBREAK = &H20
Const MF_MENUBREAK = &H40
Const MF_UNHILITE = &H0
Const MF_HILITE = &H80
Const GWL_WNDPROC = (-4)
Const IDM_APROPOS As Long = 1010
Const IDM_AJOUTER As Long = 1011
Const IDM_MODIFIER As Long = 1012
Const IDM_QUITTER As Long = 1013
Dim lProcOld As Long
Dim SIcone As IconeTray
Dim r As Long
Dim IDL As ITEMIDLIST
Dim Resultat As String
Function SysMenuHandler(ByVal hWnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If iMsg = WM_SYSCOMMAND Then
If wParam = IDM_APROPOS Then
ShellAbout Principal.hWnd, App.Title, "Conçu par Patrice Waechter-Ebling " + Chr(13) + "Version 1.0.0    ©SOSPC 2003", Principal.Icon
Exit Function
End If
If wParam = IDM_AJOUTER Then
'action commande 1
End If
If wParam = IDM_MODIFIER Then
'action commande 2
End If
If wParam = IDM_QUITTER Then
End 'bye bye
End If
End If
SysMenuHandler = CallWindowProc(lProcOld, hWnd, iMsg, wParam, lParam)
End Function
Function SubClass(FormName As Form)
Dim lhSysMenu As Long, lRet As Long
lhSysMenu = GetSystemMenu(FormName.hWnd, 0&)
lRet = AppendMenu(lhSysMenu, MF_STRING + MF_GRAYED, IDM_APROPOS, "© Papy67")
lRet = AppendMenu(lhSysMenu, MF_SEPARATOR, 0&, vbNullString)
lRet = AppendMenu(lhSysMenu, MF_STRING, IDM_AJOUTER, "Titre de la commande")
lRet = AppendMenu(lhSysMenu, MF_STRING, IDM_MODIFIER, "Titre de la commande")
lRet = AppendMenu(lhSysMenu, MF_SEPARATOR, 0&, vbNullString)
lRet = AppendMenu(lhSysMenu, MF_STRING, IDM_APROPOS, "À Propos d'" + App.Title)
lRet = AppendMenu(lhSysMenu, MF_SEPARATOR, 0&, vbNullString)'remplace le fameux Fermeture  Alt+F4
lRet = AppendMenu(lhSysMenu, MF_STRING, IDM_QUITTER, "Terminer ce programme")
FormName.Show
lProcOld = SetWindowLong(FormName.hWnd, GWL_WNDPROC, AddressOf SysMenuHandler)
End Function
Function CacherFormQuery(Fiche As Form)
Dim hSysMenu As Long, nCnt As Long
hSysMenu = GetSystemMenu(Fiche.hWnd, False)
If hSysMenu Then
nCnt = GetMenuItemCount(hSysMenu)
If nCnt Then
RemoveMenu hSysMenu, nCnt - 1, MF_BYPOSITION Or MF_REMOVE
RemoveMenu hSysMenu, nCnt - 2, MF_BYPOSITION Or MF_REMOVE
RemoveMenu hSysMenu, nCnt - 3, MF_BYPOSITION Or MF_REMOVE
RemoveMenu hSysMenu, nCnt - 4, MF_BYPOSITION Or MF_REMOVE
RemoveMenu hSysMenu, nCnt - 5, MF_BYPOSITION Or MF_REMOVE
RemoveMenu hSysMenu, nCnt - 6, MF_BYPOSITION Or MF_REMOVE
DrawMenuBar Fiche.hWnd
End If
End If
End Function
Function DoTrayIcon(Commande As Long, Fiche As Form)
SIcone.cbSize = Len(SIcone)
SIcone.hWnd = Fiche.hWnd
SIcone.uID = 1&
SIcone.uFlags = Icone Or TIP Or message
SIcone.uCallbackMessage = MOUSEMOVE
SIcone.hIcon = Fiche.Icon
SIcone.szTip = App.Title
Shell_NotifyIcon Commande, SIcone
End Function
Function GetIni() As String
If Right$(App.Path, 1) = "\" Then
GetIni = App.Path & App.EXEName & ".lst"
Else
GetIni = App.Path & "\" & App.EXEName & ".lst"
End If
End Function
Function TestEntrees()
If Val(LireDonnes("Contenu", "Nombre")) = 0 Then
X = MsgBox("Il n'y a aucune entrée" + Chr(13) + "Désirez vous en ajouter une ?", vbInformation + vbYesNo + vbDefaultButton1, "contôle des données")
If X = 6 Then Ajouter.Visible = True
End If
End Function
Function GetSpecialfolder(CSIDL As Long) As String
r = SHGetSpecialFolderLocation(100, CSIDL, IDL)
If r = NOERROR Then
Path$ = Space$(512)
r = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal Path$)
GetSpecialfolder = Left$(Path, InStr(Path, Chr$(0)) - 1)
Exit Function
End If
GetSpecialfolder = ""
End Function
Function EcrireDonnes(Section As String, Clef As String, Valeur As String)
WritePrivateProfileString Section, Clef, Valeur, GetIni
End Function
Function LireDonnes(Section As String, Clef As String) As String
Resultat = String(255, 0)
LireDonnes = Left$(Resultat, GetPrivateProfileString(Section, Clef, "", Resultat, Len(Resultat), GetIni))
End Function
Sub Main()
Principal.Caption = Time
CacherFormQuery Feuille1
SubClass Feuille1
DoTrayIcon 0, Feuille1
End Sub

'dans la feuille ici appelé Feuille1 eh bein en fait elle ne sert presque à rien 
'sauf que pour l'affichage du menu sou jassant
'et bien s'icone de l'application 
'rien n'empeche une compinaison a une feuille deja pour vue de fontions 
'autres telle que par ex un timer etc....

Conclusion :


beaucoup des ifnos viennents de MSDN et API Guide
les sous routines sont de moi sauf DoTrayIcon qui est une modification d'une source trouvée ici
Les conversions de C++ en VB sont de mon ami CVSDEV que je remerci pour son aide.
PS: si l'un d'entre vous a vb4 qu'il l'essaye pour me dire si ca amrche aussi
Merci
Télécharger le projet

Codes Sources

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 (cs_Papy67)