Mit folgenden Code wird das Menü verwendet, dass z. B. in OfficeXP zur anwendung kommt. Auf der linken Menüseite können zusätzlich noch Icons mit einer Auflösung von 16 x 16 Pixeln angezeigt werden. Ist deren Hintergrund Magenta (= &HFF00FF), so wird dieser transparent. ACHTUNG: Die Prozedur verwendet Subclassing! Bei Programmfehlern kann die ganze IDE abschmiern!!! Außerdem sollte das Subclassing vor dem Beenden deaktiviert und die Form mit Unload entladen werden!
Folgender Code muss in die Form eingefügt werden, deren Menüs im Office-Look angezeigt werden soll: Private Sub Form_Load() ' OfficeMenü verwenden SetProc Me.hwnd MakeMenuOfficeStyle Me.hwnd ' Icon zu Menü-Eintrag hinzufügen ' > MenunID = Fortlaufende Nummer des Menüeintrags ' > Unchecked = Handle des Menü-Icons (hdc) ' > Checked = Icon wenn Menü-Eintrag ausgewählt SetMenuItemPicture 2, Picture1(0).hdc SetMenuItemPicture 5, Picture1(1).hdc SetMenuItemPicture 6, Picture1(2).hdc SetMenuItemPicture 11, Picture1(3).hdc End Sub Private Sub mMenu_Click(Index As Integer) ' Beenden If Index = 5 Then Unload Me End If End Sub Private Sub Form_Unload(Cancel As Integer) ' Subclassing korrekt beenden DelProc Me.hwnd End Sub Die darzustellenden Symbole befinden sich in obigem Beispiel in einem PictureBox-Controlarray. Der restliche Code kommt in ein Modul: Option Explicit ' Code by Martin Walcher ' info@martinwalcher.de ' http://www.martinwalcher.de/ Private Declare Function SetWindowLong Lib "user32.dll" _ Alias "SetWindowLongA" ( _ ByVal hwnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Private Declare Function CallWindowProc Lib "user32.dll" _ Alias "CallWindowProcA" ( _ ByVal lpPrevWndFunc As Long, _ ByVal hwnd As Long, _ ByVal msg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long Private Declare Function SetPixel Lib "gdi32.dll" ( _ ByVal hdc As Long, _ ByVal x As Long, _ ByVal y As Long, _ ByVal crColor As Long) As Long Private Declare Function GetSysColor Lib "user32.dll" ( _ ByVal nIndex As Long) As Long Private Declare Function CreatePen Lib "gdi32.dll" ( _ ByVal nPenStyle As Long, _ ByVal nWidth As Long, _ ByVal crColor As Long) As Long Private Declare Function CreateSolidBrush Lib "gdi32.dll" ( _ ByVal crColor As Long) As Long Private Declare Function Rectangle Lib "gdi32.dll" ( _ ByVal hdc As Long, _ ByVal X1 As Long, _ ByVal Y1 As Long, _ ByVal X2 As Long, _ ByVal Y2 As Long) As Long Private Declare Function SelectObject Lib "gdi32.dll" ( _ ByVal hdc As Long, _ ByVal hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32.dll" ( _ ByVal hObject As Long) As Long Private Declare Function SetTextColor Lib "gdi32.dll" ( _ ByVal hdc As Long, _ ByVal crColor As Long) As Long Private Declare Function TextOut Lib "gdi32.dll" _ Alias "TextOutA" ( _ ByVal hdc As Long, _ ByVal x As Long, _ ByVal y As Long, _ ByVal lpString As String, _ ByVal nCount As Long) As Long Private Declare Function SetBkMode Lib "gdi32.dll" ( _ ByVal hdc As Long, _ ByVal nBkMode As Long) As Long Private Declare Function GetMenu Lib "user32.dll" ( _ ByVal hwnd As Long) As Long Private Declare Function GetSubMenu Lib "user32.dll" ( _ ByVal hMenu As Long, _ ByVal nPos As Long) As Long Private Declare Function GetMenuString Lib "user32.dll" _ Alias "GetMenuStringA" ( _ ByVal hMenu As Long, _ ByVal wIDItem As Long, _ ByVal lpString As String, _ ByVal nMaxCount As Long, _ ByVal wFlag As Long) As Long Private Declare Function LineTo Lib "gdi32.dll" ( _ ByVal hdc As Long, _ ByVal x As Long, _ ByVal y As Long) As Long Private Declare Function GetMenuState Lib "user32.dll" ( _ ByVal hMenu As Long, _ ByVal wID As Long, _ ByVal wFlags As Long) As Long Private Declare Function ModifyMenu Lib "user32.dll" _ Alias "ModifyMenuA" ( _ ByVal hMenu As Long, _ ByVal nPosition As Long, _ ByVal wFlags As Long, _ ByVal wIDNewItem As Long, _ ByVal lpString As Any) As Long Private Declare Function GetMenuItemID Lib "user32.dll" ( _ ByVal hMenu As Long, _ ByVal nPos As Long) As Long Private Declare Function SetMenuItemBitmaps Lib "user32.dll" ( _ ByVal hMenu As Long, _ ByVal nPosition As Long, _ ByVal wFlags As Long, _ ByVal hBitmapUnchecked As Long, _ ByVal hBitmapChecked As Long) As Long Private Declare Function GetMenuItemCount Lib "user32.dll" ( _ ByVal hMenu As Long) As Long Private Declare Function GetMenuItemInfo Lib "user32.dll" _ Alias "GetMenuItemInfoA" ( _ ByVal hMenu As Long, _ ByVal un As Long, _ ByVal b As Boolean, _ ByRef lpMenuItemInfo As MENUITEMINFO) As Long Private Declare Function TransparentBlt Lib "msimg32.dll" ( _ ByVal hdc As Long, _ ByVal x As Long, _ ByVal y As Long, _ ByVal nWidth As Long, _ ByVal nHeight As Long, _ ByVal hSrcDC As Long, _ ByVal xSrc As Long, _ ByVal ySrc As Long, _ ByVal nSrcWidth As Long, _ ByVal nSrcHeight As Long, _ ByVal crTransparent As Long) As Long Private Declare Sub CopyMemory Lib "kernel32.dll" _ Alias "RtlMoveMemory" ( _ ByRef Destination As Any, _ ByRef Source As Any, _ ByVal Length As Long) Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type MEASUREITEMSTRUCT CtlType As Long CtlID As Long itemID As Long itemWidth As Long itemHeight As Long itemData As Long End Type Private Type DRAWITEMSTRUCT CtlType As Long CtlID As Long itemID As Long itemAction As Long itemState As Long hwndItem As Long hdc As Long rcItem As RECT itemData As Long End Type Private 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 Private Const GWL_WNDPROC As Long = -4 Private Const WM_MEASUREITEM As Long = &H2C Private Const WM_DRAWITEM As Long = &H2B Private Const COLOR_BACKGROUND As Long = 1 Private Const COLOR_MENU As Long = 4 Private Const COLOR_MENUTEXT As Long = 7 Private Const PS_SOLID As Long = 0 Private Const TRANSPARENT As Long = 1 Private Const MF_SEPARATOR As Long = &H800& Private Const MF_BYPOSITION As Long = &H400& Private Const MF_OWNERDRAW As Long = &H100& Private Const MIIM_CHECKMARKS As Long = &H8 Private Const MIIM_STATE As Long = &H1 Private Const MF_CHECKED As Long = &H8& Dim oldProc As Long Dim menuhandle As Long Sub DelProc(ByVal hwnd As Long) SetWindowLong hwnd, GWL_WNDPROC, oldProc End Sub Public Function MakeMenuOfficeStyle(ByVal hwnd As Long) As Boolean Dim xm As Long, m As Long, i As Long xm = GetMenu(hwnd) menuhandle = xm For i = 0 To GetMenuItemCount(xm) m = GetSubMenu(xm, i) If m > 0 Then StyleSubMenu m Next i End Function Private Function StyleSubMenu(ByVal xm As Long) Dim m As Long, i As Long For i = 0 To GetMenuItemCount(xm) m = GetMenuItemID(xm, i) If m = -1 Then m = GetSubMenu(xm, i) If m > 0 Then StyleSubMenu m End If If m > 0 Then ModifyMenu xm, m, GetMenuState(xm, m, 0) _ Or MF_OWNERDRAW, m, GetMenuText(xm, m) End If Next i End Function Private Function GetMenuText(ByVal m As Long, _ ByVal id As Long, _ Optional ByVal flags As Long = 0) As String GetMenuText = Space(64) GetMenuString m, id, GetMenuText, Len(GetMenuText), flags GetMenuText = Left(GetMenuText, InStr(GetMenuText & Chr(0), Chr(0)) - 1) End Function Private Function GetMenuBitmap(ByVal MenuID As Long) As Long On Error Resume Next Dim itemchecked As Boolean, mi As MENUITEMINFO, lngTmp As Long mi.cbSize = Len(mi) mi.fMask = MIIM_STATE GetMenuItemInfo menuhandle, MenuID, False, mi itemchecked = ((mi.fState And MF_CHECKED) = MF_CHECKED) mi.fMask = MIIM_CHECKMARKS GetMenuItemInfo menuhandle, MenuID, False, mi If itemchecked Then GetMenuBitmap = mi.hbmpChecked Else GetMenuBitmap = mi.hbmpUnchecked End If End Function Sub SetProc(ByVal hwnd As Long) oldProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf NewProc) End Sub Private Function NewProc(ByVal hwnd As Long, _ ByVal msg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long Dim mis As MEASUREITEMSTRUCT, dis As DRAWITEMSTRUCT Dim r As RECT, s As String, x As Long, y As Long Dim c As Long, rc As Long, gc As Long, bc As Long Select Case msg Case WM_MEASUREITEM CopyMemory mis, ByVal lParam, Len(mis) If mis.itemID > 0 Then mis.itemWidth = 173 If (GetMenuState(GetMenu(hwnd), mis.itemID, 0) _ And MF_SEPARATOR) = MF_SEPARATOR Then mis.itemHeight = 3 Else mis.itemHeight = 24 End If CopyMemory ByVal lParam, mis, Len(mis) End If Case WM_DRAWITEM CopyMemory dis, ByVal lParam, Len(dis) If dis.itemID >0 Then s = Space(64) GetMenuString GetMenu(hwnd), dis.itemID, s, Len(s), 0 s = Left(s, InStr(s & Chr(0), Chr(0)) - 1) If Not s = "" Then s = Split(s, vbTab, 2)(0) s = Replace(s, "&", "") End If Select Case dis.itemState And 1 Case 0 DrawRect dis.hdc, dis.rcItem, vbWhite, &HFFFFFF For x = dis.rcItem.Left To dis.rcItem.Left + 25 rc = 255 - Round(x / 26 * (257 - 212)) gc = 255 - Round(x / 26 * (257 - 208)) bc = 255 - Round(x / 26 * (257 - 200)) c = rc + gc * 256 + bc * 256 ^ 2 For y = dis.rcItem.Top To dis.rcItem.Bottom SetPixel dis.hdc, x, y, c Next y Next x Select Case (dis.itemState And 6) = 6 Case True r.Left = dis.rcItem.Left + 30 r.Right = dis.rcItem.Right r.Top = dis.rcItem.Top + 2 r.Bottom = r.Top + 1 DrawRect dis.hdc, r, &H808080, &H808080 Case False SetBkMode dis.hdc, TRANSPARENT SetTextColor dis.hdc, 0 TextOut dis.hdc, dis.rcItem.Left + 34, dis.rcItem.Top + _ (dis.rcItem.Bottom - dis.rcItem.Top) / 2 - 12 / 2, s, Len(s) End Select Case 1 r.Left = dis.rcItem.Left + 1 r.Top = dis.rcItem.Top + 1 r.Right = dis.rcItem.Right - 1 r.Bottom = dis.rcItem.Bottom DrawRect dis.hdc, r, &H6A240A, &HD0BAB2 ' für unregelmäßige Rechtecke ' vor MakeDiffuseRect entfernen ' MakeDiffuseRect dis.hdc, r, 20 SetBkMode dis.hdc, TRANSPARENT SetTextColor dis.hdc, 0 TextOut dis.hdc, dis.rcItem.Left + 34, dis.rcItem.Top + _ (dis.rcItem.Bottom - dis.rcItem.Top) / 2 - 12 / 2, s, Len(s) End Select c = GetMenuBitmap(dis.itemID) If Not c = 0 Then TransparentBlt dis.hdc, dis.rcItem.Left + 5 - (dis.itemState And 1), _ dis.rcItem.Top + 4 - (dis.itemState And 1), 16, 16, c, 0, 0, 16, 16, vbMagenta End Select NewProc = CallWindowProc(oldProc, hwnd, msg, wParam, lParam) End Function Private Sub DrawRect(ByVal hdc As Long, r As RECT, _ ByVal bc As Long, ByVal fc As Long) Dim hp As Long, hb As Long hp = CreatePen(PS_SOLID, 0, bc) hb = CreateSolidBrush(fc) SelectObject hdc, hp SelectObject hdc, hb Rectangle hdc, r.Left, r.Top, r.Right, r.Bottom DeleteObject hb DeleteObject hp End Sub Private Function MakeDiffuseRect(ByVal hdc As Long, _ r As RECT, ByVal anzahl As Long) As Boolean Dim i As Long For i = 1 To anzahl DrawDiffuseRect hdc, r Next i End Function Private Function DrawDiffuseRect(ByVal hdc As Long, _ r As RECT) As Boolean Dim nr As RECT, c As Long nr.Left = Rnd * (r.Right - r.Left - Rnd * 40) + r.Left If nr.Left <= r.Left Then nr.Left = r.Left + 1 nr.Right = nr.Left + Rnd * 30 + 10 If nr.Right >= r.Right Then nr.Right = r.Right - 1 nr.Top = Rnd * (r.Bottom - r.Top - Rnd * 30) + r.Top If nr.Top <= r.Top Then nr.Top = r.Top + 1 nr.Bottom = nr.Top + Rnd * 20 + 10 If nr.Bottom >= r.Bottom Then nr.Bottom = r.Bottom - 1 c = 20 c = RGB(178 + Rnd * c - c / 2, 186 + Rnd * c - c / 2, 208 + Rnd * c - c / 2) DrawRect hdc, nr, c, c End Function Public Function SetMenuItemPicture(ByVal MenuID As Long, _ Optional ByVal Unchecked As Long = 0, _ Optional ByVal Checked As Long = 0) As Long Dim lngTmp As Long Dim lngEntry As Long lngEntry = FindMenuHandle(menuhandle, MenuID) SetMenuItemPicture = SetMenuItemBitmaps(menuhandle, lngEntry, _ 0, Unchecked, Checked) End Function Private Function FindMenuHandle(ByVal lngMenu As Long, _ lngID As Long) As Long Select Case GetMenuState(lngMenu, lngID, 0) Case -1 FindMenuHandle = FindMenuHandleb(lngMenu, lngID) Case Else FindMenuHandle = lngID End Select End Function Private Function FindMenuHandleb(ByVal lngMenu As Long, lngID As Long, _ Optional lngCur As Long = 1) As Long Dim lngSubMenu As Long Dim i As Long For i = 0 To GetMenuItemCount(lngMenu) - 1 lngSubMenu = GetMenuItemID(lngMenu, i) If lngSubMenu = -1 Then lngSubMenu = GetSubMenu(lngMenu, i) If lngCur = lngID Then FindMenuHandleb = lngSubMenu: Exit For lngCur = lngCur + 1 FindMenuHandleb = FindMenuHandleb(lngSubMenu, lngID, lngCur) If Not FindMenuHandleb = 0 Then Exit Function Else If lngCur = lngID Then FindMenuHandleb = lngSubMenu: Exit For lngCur = lngCur + 1 End If Next i End Function Dieser Tipp wurde bereits 18.724 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
sevISDN 1.0 Überwachung aller eingehender Anrufe! Die DLL erkennt alle über die CAPI-Schnittstelle eingehenden Anrufe und teilt Ihnen sogar mit, aus welchem Ortsbereich der Anruf stammt. Weitere Highlights: Online-Rufident, Erkennung der Anrufbehandlung u.v.m. Tipp des Monats April 2024 Skyfloy Chart von Microsoft und dazu noch gratis Tutorial für Microsoft Chart Controls für Microsoft .NET Framework 3.5 Neu! sevCommand 4.0 Professionelle Schaltflächen im modernen Design! Mit nur wenigen Mausklicks statten auch Sie Ihre Anwendungen ab sofort mit grafischen Schaltflächen im modernen Look & Feel aus (WinXP, Office, Vista oder auch Windows 8), inkl. große Symbolbibliothek. |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |