AJOUT DE SOUS MENU DYNAMIQUEMENT

Commentaire de AngeliusMefyrx le 16/03/2007 17:45:07

*********************Ce que ça fait*******************
Base de données Access
Lorsqu'on charge le programme, ça accès une base de données Access
Ca créer alors un menu dynamique et attribue une commande afilié à celle ci

J'ai mis pas mal toute le code que je croyais utile
Inutilie de dire qu'il faut appeller la function dans le Form Load
De plus, cela attribue un menu au 6e menu de la fenetre aupréalablement créer avec rien dedans
Pour le premier, juste remplacer le 6 par 0 aux 2 endroits approprié
chemin = Le chemin de la BD access
DBPassword = Mettre ce que vous voulez si ya un mot de passe, sinon enlever la derniere option qui load la BD
Désoler mais, ça fait partis d'un programme que je fais, donc j'ai simplement copier le code lier à cette partie...j,espère rien avoir oublier

*************************BD ACCESS***********************
Table:
DBA_Raccourci

Champs:
Application Exemple: Boite de partage
Liens       Exemple: iexplore "http://support.lexmark.com/cgi-perl/knowledgebase.cgi?ccs=37:3:0:101:0:0&docid=ENUS8664"
Categorie   Exemple: Liens Internet

*************************MODULE***********************

Public pOldProc As Long
Public pOldProc2 As Long

Public Declare Function CreatePopupMenu Lib "user32" () As Long
Public Declare Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, ByRef lpcMenuItemInfo As MENUITEMINFO) As Long
Public Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
Public Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFO) As Long
Public Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public 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

Public Type MENUITEMINFO
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
    hSubMenu As Long
    hbmpChecked As Long
    hbmpUnchecked As Long
    dwItemData As Long
    dwTypeData As String
    cch As Long
End Type

Public retval As Long
Public chemin As String

Public mii1 As MENUITEMINFO 'strucutre d'info d'un menu


Public Const MIIM_STATE = &H1
Public Const MIIM_ID = &H2
Public Const MIIM_SUBMENU = &H4
Public Const MIIM_CHECKMARKS = &H8
Public Const MIIM_DATA = &H20
Public Const MIIM_TYPE = &H10
Public Const MFT_BITMAP = &H4
Public Const MFT_MENUBARBREAK = &H20
Public Const MFT_MENUBREAK = &H40
Public Const MFT_OWNERDRAW = &H100
Public Const MFT_RADIOCHECK = &H200
Public Const MFT_RIGHTJUSTIFY = &H4000
Public Const MFT_RIGHTORDER = &H2000
Public Const MFT_SEPARATOR = &H800
Public Const MFT_STRING = &H0
Public Const MFS_CHECKED = &H8
Public Const MFS_DEFAULT = &H1000
Public Const MFS_DISABLED = &H2
Public Const MFS_ENABLED = &H0
Public Const MFS_GRAYED = &H1
Public Const MFS_HILITE = &H80
Public Const MFS_UNCHECKED = &H0
Public Const MFS_UNHILITE = &H0

Public Const WM_COMMAND = &H111

Public Const GWL_WNDPROC = -4
Public Const DBPassword = ""


Public hPopupMenu1 As Long 'handle du menu déroulant
Public hPopupSMenu1 As Long
Public hPopupSMenu2 As Long

Public hMenu As Long 'handle pour manipuler le menu "FICHIER" temporairement

Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096


Public conDatabase As Database
Public Table_Menu_App() As String
Public Table_Menu_App_H As Integer


Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim i As Integer
If uMsg = WM_COMMAND Then
    For i = 0 To Table_Menu_App_H
        If Table_Menu_App(2, i) <> "" And Table_Menu_App(0, i) = wParam Then
            Set go = CreateObject("WScript.Shell")
            go.run Table_Menu_App(2, i)
        End If
    Next i
End If
WindowProc = CallWindowProc(pOldProc, hwnd, uMsg, wParam, lParam)
End Function



Rem ***************************************** Frm_Main *******************************************

Private Sub Load_Menu_Favoris()
Dim StrSQL As String
Dim Rs As Recordset
hPopupMenu1 = CreatePopupMenu()
Dim CategorieTmp As String
Dim Incrementeur As Integer
Incrementeur = 100
Table_Menu_App_H = -1

Set conDatabase = OpenDatabase(chemin, Options, ReadOnly, "MS Access;pwd=" & DBPassword)
StrSQL = "SELECT * FROM DBA_Raccourci ORDER BY Categorie DESC, Application DESC"
Set Rs = conDatabase.OpenRecordset(StrSQL)

If Rs.RecordCount > 0 Then
    Rs.MoveFirst
    Do Until Rs.EOF
        If Rs.Fields("Categorie") <> CategorieTmp Then
            Incrementeur = Incrementeur + 1
            hPopupSMenu1 = CreatePopupMenu()
            CategorieTmp = Rs.Fields("Categorie")
            With mii1
                .cbSize = Len(mii1)
                .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
                .fState = MFS_ENABLED
                .wID = Incrementeur
                .fType = MFT_STRING
                .dwTypeData = Rs.Fields("Categorie")
                .cch = Len(.dwTypeData)
            End With
            retval = InsertMenuItem(hPopupMenu1, 0, 1, mii1)
            hMenu = GetMenu(Frm_Main.hwnd)
            retval = GetMenuItemInfo(hMenu, 6, 1, mii1)  'Le 7e menu dans la liste
            With mii1
                .cbSize = Len(mii1)
                .fMask = MIIM_SUBMENU
                .hSubMenu = hPopupMenu1
            End With
            retval = SetMenuItemInfo(hMenu, 6, 1, mii1)  'Le 7e menu dans la liste
        End If
        
        Incrementeur = Incrementeur + 1
        Table_Menu_App_H = Table_Menu_App_H + 1
        ReDim Preserve Table_Menu_App(0 To 2, 0 To Table_Menu_App_H)
        Table_Menu_App(0, Table_Menu_App_H) = Incrementeur
        Table_Menu_App(1, Table_Menu_App_H) = Rs.Fields("Application")
        Table_Menu_App(2, Table_Menu_App_H) = Rs.Fields("Liens")
        
        With mii1
            .cbSize = Len(mii1)
            .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
            .fState = MFS_ENABLED
            .wID = Incrementeur
            .fType = MFT_STRING
            .dwTypeData = Rs.Fields("Application")
            .cch = Len(.dwTypeData)
        End With
        retval = InsertMenuItem(hPopupSMenu1, 0, 1, mii1)
        retval = GetMenuItemInfo(hPopupMenu1, 0, 1, mii1)
        With mii1
            .cbSize = Len(mii1)
            .fMask = MIIM_SUBMENU
            .hSubMenu = hPopupSMenu1
        End With
        retval = SetMenuItemInfo(hPopupMenu1, 0, 1, mii1)
        Rs.MoveNext
    Loop
End If
pOldProc = SetWindowLong(Frm_Main.hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub