vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#

https://www.vbarchiv.net
Rubrik: System/Windows · Sonstiges   |   VB-Versionen: VB620.01.05
Startmenü nachbauen

Coole Effekte für Menüs anstatt des langweiligen Standard-Looks

Autor:   Martin WalcherBewertung:  Views:  16.827 
www.martinwalcher.deSystem:  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:

  1. Balken auf der linken Seite und
  2. 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



Anzeige

Kauftipp Unser Dauerbrenner!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.
 
 
Copyright ©2000-2024 vb@rchiv Dieter OtterAlle Rechte vorbehalten.


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.