Rubrik: System/Windows · Sonstiges | VB-Versionen: VB6 | 20.01.05 |
Startmenü nachbauen Coole Effekte für Menüs anstatt des langweiligen Standard-Looks | ||
Autor: Martin Walcher | Bewertung: | Views: 16.827 |
www.martinwalcher.de | System: WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 | Beispielprojekt auf CD |
Mit folgenden Code kann man ganz einfach eine "Kopie" des Startmenüs erzeugen (nicht das hässliche Dicke, sondern das klassische..). Dies gibt z.B. bei SysTray-Menüs einiges mehr her als das zierliche Windows-Standard-Menü ;)
Der Code besteht aus zwei Teilen:
- Balken auf der linken Seite und
- Anzeige von großen Icons (24x24 Pixel)
ACHTUNG: Die Prozedur verwendet Subclassing! Bei Programmfehlern kann die ganze IDE abschmiern!!!
Abb.: modernes "Sidebar"-Menü
Zur Anwendung der Funktionen muss nachfolgender Code in eine Form eingefügt werden.
Wichtig: Das anzuzeigende Menü muss vorher über den VB-Menüeditor erstellt werden!
Die einzelnen Bildsymbole legen Sie am besten in einem Picture-Control ab (Steuerelementfeld).
Private Sub Form_Load() ' Erstellen der SideBar: ' > HWnd: handle eines Fensters ' > MenuID: ID des Menüs (0 = 1. Menü, 1 = 2. Menü...) ' --> AddSidebar HWnd, MenuID AddSidebar Me.hwnd, 0 ' Änderung der SubItems: ' > HWnd: handle eines Fensters ' > MenuID siehe oben ' > SubID: des Menüeintrags (wie MenuID) ' ABER: Wenn SideBar vorhanden: SubID = SubID + 1 ' > hdc: Handle eines Bildes (24 x 24px) ' --> MakeBigIcon Me.hwnd, MenuID, SubID, hdc MakeBigIcon HWnd, 0, 1, Picture1(0).hdc MakeBigIcon Me.hwnd, 0, 2, Picture1(1).hdc End Sub
Der restliche Code kommt in ein Modul:
Option Explicit ' Code by Martin Walcher ' info@martinwalcher.de ' http://www.martinwalcher.de/ 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 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 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 GetMenuItemID Lib "user32.dll" ( _ ByVal hMenu As Long, _ ByVal nPos As Long) As Long 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 GetSystemMetrics Lib "user32.dll" ( _ ByVal nIndex As Long) As Long Private Declare Function GetClipBox Lib "gdi32.dll" ( _ ByVal hdc As Long, _ ByRef lpRect As RECT) 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 ChangeMenu Lib "user32.dll" _ Alias "ChangeMenuA" ( _ ByVal hMenu As Long, _ ByVal cmd As Long, _ ByVal lpszNewItem As String, _ ByVal cmdInsert As Long, _ ByVal flags 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 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 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 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 BitBlt Lib "gdi32.dll" ( _ ByVal hDestDC 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 dwRop As Long) 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 Function SetBkMode Lib "gdi32.dll" ( _ ByVal hdc As Long, _ ByVal nBkMode 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 Sub CopyMemory Lib "kernel32.dll" _ Alias "RtlMoveMemory" ( _ ByRef Destination As Any, _ ByRef Source As Any, _ ByVal Length As Long) Private Const MF_BYPOSITION As Long = &H400& Private Const MF_MENUBREAK As Long = &H40& Private Const MF_DISABLED As Long = &H2& Private Const MF_GRAYED As Long = &H1& Private Const MF_OWNERDRAW As Long = &H100& Private Const WM_MEASUREITEM As Long = &H2C& Private Const WM_DRAWITEM As Long = &H2B& Private Const SM_CXMENUCHECK As Long = &H47& Private Const GWL_WNDPROC As Long = -4 Private Const COLOR_MENU As Long = 4 Private Const COLOR_MENUTEXT As Long = 7 Private Const COLOR_HIGHLIGHT As Long = 13 Private Const COLOR_HIGHLIGHTTEXT As Long = 14 Private Const PS_SOLID As Long = 0 Private Const SRCCOPY As Long = &HCC0020 Private Const TRANSPARENT As Long = 1 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 Dim oldProc As Long
Public Function AddSidebar(ByVal hwnd As Long, ByVal MenuNr As Long) As Boolean Dim m As Long, s As String SetProc hwnd m = GetSubMenu(GetMenu(hwnd), MenuNr) If m = 0 Then Exit Function ChangeMenu m, 0, "", 0, MF_BYPOSITION ModifyMenu m, 0, MF_BYPOSITION Or MF_OWNERDRAW Or _ MF_DISABLED Or MF_GRAYED, GetMenuItemID(m, 0), -1& s = Space(128) GetMenuString m, 1, s, Len(s), MF_BYPOSITION s = Left(s, InStr(s & Chr(0), Chr(0)) - 1) ModifyMenu m, 1, GetMenuState(m, 1, MF_BYPOSITION) Or _ MF_BYPOSITION Or MF_MENUBREAK, GetMenuItemID(m, 1), s AddSidebar = True End Function
Public Function MakeBigIcon(ByVal hwnd As Long, ByVal MenuNr As Long, _ ByVal MenuPos As Long, ByVal iconhdc As Long) As Boolean Dim m As Long, s As String SetProc hwnd m = GetSubMenu(GetMenu(hwnd), MenuNr) If m = 0 Then Exit Function If iconhdc = -1 Then iconhdc = 0 ModifyMenu m, MenuPos, GetMenuState(m, MenuPos, MF_BYPOSITION) Or _ MF_BYPOSITION Or MF_OWNERDRAW, GetMenuItemID(m, MenuPos), iconhdc MakeBigIcon = True End Function
Private Sub SetProc(ByVal hwnd As Long) If oldProc = 0 Then oldProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf NewProc) End Sub
Public Sub DelProc(ByVal hwnd As Long) SetWindowLong hwnd, GWL_WNDPROC, oldProc oldProc = 0 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 Dim dis As DRAWITEMSTRUCT Dim tmp As Long Dim x As Long Dim y As Long Dim bc As Long Dim fc As Long Dim hp As Long Dim hb As Long, s As String Select Case msg Case WM_MEASUREITEM CopyMemory ByVal VarPtr(mis), ByVal lParam, Len(mis) If mis.itemData = -1 Then mis.itemWidth = 21 - GetSystemMetrics(SM_CXMENUCHECK) - 3 mis.itemHeight = 0 Else mis.itemHeight = 32 mis.itemWidth = 150 End If CopyMemory ByVal lParam, ByVal VarPtr(mis), Len(mis) Case WM_DRAWITEM CopyMemory ByVal VarPtr(dis), ByVal lParam, Len(dis) If dis.itemData = -1 Then GetClipBox dis.hdc, dis.rcItem tmp = dis.rcItem.Bottom - dis.rcItem.Top For y = 0 To tmp For x = 0 To 20 SetPixel dis.hdc, x, y, Round(y / tmp * 255) * 256 Next Next Else Select Case dis.itemState And 1 Case 1 ' Selected bc = GetSysColor(COLOR_HIGHLIGHT) fc = GetSysColor(COLOR_HIGHLIGHTTEXT) Case 0 ' Not Selected bc = GetSysColor(COLOR_MENU) fc = GetSysColor(COLOR_MENUTEXT) End Select hp = CreatePen(PS_SOLID, 0, bc) hb = CreateSolidBrush(bc) SelectObject dis.hdc, hp SelectObject dis.hdc, hb Rectangle dis.hdc, dis.rcItem.Left, dis.rcItem.Top, _ dis.rcItem.Right, dis.rcItem.Bottom DeleteObject hb DeleteObject hp TransparentBlt dis.hdc, dis.rcItem.Left + 4, dis.rcItem.Top + 4, _ 24, 24, dis.itemData, 0, 0, 24, 24, &HFF00FF ' &HC8D0D4 SetBkMode dis.hdc, TRANSPARENT SetTextColor dis.hdc, fc s = Space(64) GetMenuString GetMenu(hwnd), dis.itemID, s, Len(s), 0 s = Left(s, InStr(s & Chr(0), Chr(0)) - 1) TextOut dis.hdc, dis.rcItem.Left + 40, dis.rcItem.Top + _ (dis.rcItem.Bottom - dis.rcItem.Top) / 2 - 12 / 2, s, Len(s) End If End Select NewProc = CallWindowProc(oldProc, hwnd, msg, wParam, lParam) End Function