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:
ACHTUNG: Die Prozedur verwendet Subclassing! Bei Programmfehlern kann die ganze IDE abschmiern!!!
Zur Anwendung der Funktionen muss nachfolgender Code in eine Form eingefügt 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 Dieser Tipp wurde bereits 16.828 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 März 2024 Dieter Otter UTF-8 Konvertierung von Dateien und Strings VB6 selbst verfügt über keine Funktionen zur UTF-8 Konvertierung von Daten. Mit Hilfe des ADODB.Stream-Objekts lassen sich diese fehlenden Funktionen aber schnell nachrüsten. Neu! sevPopUp 2.0 Dynamische Kontextmenüs! Erstellen Sie mit nur wenigen Zeilen Code Kontextmenüs dynamisch zur Laufzeit. Vordefinierte Styles (XP, Office, OfficeXP, Vista oder Windows 8) erleichtern die Anpassung an die eigenen Anwendung... |
||||||||||||||||
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. |