basflatmenu.bas

VB下开发Windows XP风格的控件

Attribute VB_Name = "BasFlatMenu"
Option Explicit
'FlatMenu——XP阴影风格菜单的制作方法
'
'作者: zyl910
'2002.12.19

'## Hook ########################################
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetWindowsHook Lib "user32" Alias "SetWindowsHookA" (ByVal nFilterType As Long, ByVal pfnFilterProc As Long) As Long
Private Declare Function UnhookWindowsHook Lib "user32" (ByVal nCode As Long, ByVal pfnFilterProc As Long) As Long

Private Const WH_CALLWNDPROC     As Long = 4
Private Const WH_CALLWNDPROCRET As Long = 12

Private Const HC_ACTION      As Long = 0

Private Type CWPSTRUCT
    lParam As Long
    wParam As Long
    message As Long
    hWnd As Long
End Type

Private Type CWPRETSTRUCT
    lResult As Long
    lParam As Long
    wParam As Long
    message As Long
    hWnd As Long
End Type

'## Window ######################################
Private Declare Function GetClassNameA Lib "user32" (ByVal hWnd As Long, lpClassName As Any, ByVal nMaxCount As Long) As Long

Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Private Const SWP_NOSIZE            As Long = &H1
Private Const SWP_NOMOVE            As Long = &H2
Private Const SWP_NOZORDER          As Long = &H4
Private Const SWP_NOACTIVATE       As Long = &H10
Private Const SWP_FRAMECHANGED     As Long = &H20

Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long

Private Declare Function GetDesktopWindow Lib "user32" () As Long

Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long

'## GDI #########################################
Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Const NULL_BRUSH As Long = 5

Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long

Private Declare Function Rectangle Lib "gdi32" (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 FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long

Private Declare Function BitBlt Lib "gdi32" (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 GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long

'################################################
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

Private Const WM_SPLWND As Long = &H1E2
Private Const WM_DESTROY As Long = &H2
Private Const WM_NCDESTROY As Long = &H82
Private Const WM_SHOWWINDOW As Long = &H18
Private Const WM_NCCALCSIZE As Long = &H83
Private Const WM_NCPAINT As Long = &H85
Private Const WM_PRINT As Long = &H317

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type WINDOWPOS
    hWnd As Long
    hWndInsertAfter As Long
    X As Long
    Y As Long
    cx As Long
    cy As Long
    Flags As Long
End Type

Private Type NCCALCSIZE_PARAMS
    rgrc(0 To 3 - 1) As RECT
    lpPos            As WINDOWPOS
End Type

'================================================
Public Const WC_Menu = "#32768" '菜单窗口的类名

Private Const FlatMenuFirst As String = "FlatMenu"
Private Const FlatMenuOldMap As String = FlatMenuFirst & "OldMap"

Private Const ShadowSize As Long = 4
Private Const ShadowFirst As Single = 0.4

Private Const EdgeColor  As Long = &H606060
Private Const ShadowColor As Long = &HA0A0A0

'================================================
Private hHook As Long
Private hHookRet As Long
Private mFlatMenuing As Boolean
Public RoundRect As Boolean

Private NoSize As Boolean '不处理
Private SaveMap As Boolean '是否保存背景

Public Property Get FlatMenuing() As Boolean

    FlatMenuing = mFlatMenuing

End Property

Public Function SetFlatMenu(ByVal Value As Boolean) As Boolean

    If Value = mFlatMenuing Then
        Exit Function '>---> Bottom
    End If

    If Value Then
        'Debug.Print String$(80, "=")

        hHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf CallWndProc_Menu, 0, App.ThreadID)
        hHookRet = SetWindowsHookEx(WH_CALLWNDPROCRET, AddressOf CallWndRetProc_Menu, 0, App.ThreadID)
        'Debug.Print hHook

      Else 'VALUE = FALSE
        Call UnhookWindowsHookEx(hHook)
        Call UnhookWindowsHookEx(hHookRet)

    End If

    mFlatMenuing = Value
    'Debug.Print mFlatMenuing

    SetFlatMenu = Value

End Function

Private Function ClassName(ByVal hWnd As Long) As String

  Dim StrData(0 To &H100) As Byte
  Dim Rc As Long

    Rc = GetClassNameA(hWnd, StrData(0), &H100)
    If Rc > 0 Then
        ClassName = StrConv(LeftB(StrData, Rc), vbUnicode)
      Else 'NOT RC...
        ClassName = vbNullString
    End If

End Function

Private Function CallWndProc_Menu(ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As CWPSTRUCT) As Long

  Dim ClassStr As String

    Select Case nCode
      Case HC_ACTION

        ClassStr = ClassName(lParam.hWnd)

        'Open "c:\Debug.txt" For Append As #1
        'Print #1, lParam.hWnd, ClassStr
        'Close #1

        If ClassStr = WC_Menu Then
            'Debug.Print lParam.Message
            'With lParam
            '    Call OutMsg(.hWnd, .Message, .wParam, .lParam)
            'End With

            Select Case lParam.message
              Case WM_SPLWND
                FreeOld lParam.hWnd
                SaveMap = True

              Case WM_NCDESTROY, WM_DESTROY
                FreeOld lParam.hWnd
                SaveMap = False

              Case WM_SHOWWINDOW
                If lParam.wParam = 0 Then
                    FreeOld lParam.hWnd
                    SaveMap = False

                End If

              Case WM_NCPAINT
                SaveOld lParam.hWnd

              Case Else
                '

            End Select '结束lParam.Message判断

          Else 'NOT CLASSSTR...
            '
        End If '结束窗口类名判断

    End Select '结束nCode判断

    CallWndProc_Menu = CallNextHookEx(hHook, nCode, wParam, lParam)

End Function

Private Function SaveOld(ByVal hWnd As Long) As Boolean

  Dim WndRect As RECT
  Dim Wi As Long, He As Long
  Dim hDCDsk As Long
  Dim hDC As Long
  Dim hMap As Long
  Dim hOldMap As Long
  Dim i As Long, j As Long
  Dim MaxJ As Long
  Dim C As Long
  Dim R As Long
  Dim G As Long
  Dim b As Long
  Dim Alpha As Single

    'Debug.Print "SaveOld"

    If SaveMap = False Then
        Exit Function '>---> Bottom
    End If

    If GetProp(hWnd, FlatMenuOldMap) <> 0 Then
        Exit Function '>---> Bottom
    End If

    Call GetWindowRect(hWnd, WndRect)

    Wi = WndRect.Right - WndRect.Left
    He = WndRect.Bottom - WndRect.Top

    hDCDsk = GetWindowDC(GetDesktopWindow)
    hDC = CreateCompatibleDC(hDCDsk)
    hMap = CreateCompatibleBitmap(hDCDsk, Wi, He)
    If (hDCDsk = 0) Or (hDC = 0) Or (hMap = 0) Then
        If hDCDsk Then
            Call ReleaseDC(GetDesktopWindow, hDCDsk)
        End If
        If hDC Then
            Call DeleteDC(hDC)
        End If
        If hMap Then
            Call DeleteObject(hMap)
        End If

        Exit Function '>---> Bottom

    End If

    hOldMap = SelectObject(hDC, hMap)

    BitBlt hDC, 0, 0, Wi, He, hDCDsk, WndRect.Left, WndRect.Top, vbSrcCopy