basflatmenu.bas

VB下开发Windows XP风格的控件

    '右上
    For i = 0 To ShadowSize - 1
        For j = 0 To ShadowSize - 1
            Alpha = ShadowSize - Sqr(i * i + j * j)
            Alpha = Alpha * ShadowFirst / ShadowSize
            If Alpha > 0 Then
                Alpha = 1 - Alpha
                C = GetPixel(hDC, Wi - ShadowSize + j, ShadowSize + ShadowSize - 1 - i)
                R = C And &HFF&
                G = (C And &HFF00&) \ &H100&
                b = (C And &HFF0000) \ &H10000
                Call SetPixelV(hDC, Wi - ShadowSize + j, ShadowSize + ShadowSize - 1 - i, RGB(R * Alpha, G * Alpha, b * Alpha))

            End If

        Next j

    Next i

    '右
    MaxJ = He - ShadowSize - ShadowSize - ShadowSize - 1
    For i = 0 To ShadowSize - 1
        Alpha = ShadowSize - i
        Alpha = Alpha * ShadowFirst / ShadowSize
        If Alpha > 0 Then
            Alpha = 1 - Alpha
            For j = 0 To MaxJ
                C = GetPixel(hDC, Wi - ShadowSize + i, ShadowSize + ShadowSize + j)
                R = C And &HFF&
                G = (C And &HFF00&) \ &H100&
                b = (C And &HFF0000) \ &H10000
                Call SetPixelV(hDC, Wi - ShadowSize + i, ShadowSize + ShadowSize + j, RGB(R * Alpha, G * Alpha, b * Alpha))
            Next j
        End If

    Next i

    '右下
    For i = 0 To ShadowSize - 1
        For j = 0 To ShadowSize - 1
            Alpha = ShadowSize - Sqr(i * i + j * j)
            Alpha = Alpha * ShadowFirst / ShadowSize
            If Alpha > 0 Then
                Alpha = 1 - Alpha
                C = GetPixel(hDC, Wi - ShadowSize + j, He - ShadowSize + i)
                R = C And &HFF&
                G = (C And &HFF00&) \ &H100&
                b = (C And &HFF0000) \ &H10000
                Call SetPixelV(hDC, Wi - ShadowSize + j, He - ShadowSize + i, RGB(R * Alpha, G * Alpha, b * Alpha))

            End If

        Next j

    Next i

    '下
    MaxJ = Wi - ShadowSize - ShadowSize - ShadowSize - 1
    For i = 0 To ShadowSize - 1
        Alpha = ShadowSize - i
        Alpha = Alpha * ShadowFirst / ShadowSize
        If Alpha > 0 Then
            Alpha = 1 - Alpha
            For j = 0 To MaxJ
                C = GetPixel(hDC, ShadowSize + ShadowSize + j, He - ShadowSize + i)
                R = C And &HFF&
                G = (C And &HFF00&) \ &H100&
                b = (C And &HFF0000) \ &H10000
                Call SetPixelV(hDC, ShadowSize + ShadowSize + j, He - ShadowSize + i, RGB(R * Alpha, G * Alpha, b * Alpha))
            Next j
        End If

    Next i

    '左下
    For i = 0 To ShadowSize - 1
        For j = 0 To ShadowSize - 1
            Alpha = ShadowSize - Sqr(i * i + j * j)
            Alpha = Alpha * ShadowFirst / ShadowSize
            If Alpha > 0 Then
                Alpha = 1 - Alpha
                C = GetPixel(hDC, ShadowSize + ShadowSize - 1 - j, He - ShadowSize + i)
                R = C And &HFF&
                G = (C And &HFF00&) \ &H100&
                b = (C And &HFF0000) \ &H10000
                Call SetPixelV(hDC, ShadowSize + ShadowSize - 1 - j, He - ShadowSize + i, RGB(R * Alpha, G * Alpha, b * Alpha))

            End If

        Next j

    Next i

    '右下的那一点
    Alpha = ShadowFirst
    Alpha = 1 - Alpha
    C = GetPixel(hDC, Wi - ShadowSize - 1, He - ShadowSize - 1)
    R = C And &HFF&
    G = (C And &HFF00&) \ &H100&
    b = (C And &HFF0000) \ &H10000
    Call SetPixelV(hDC, Wi - ShadowSize - 1, He - ShadowSize - 1, RGB(R * Alpha, G * Alpha, b * Alpha))

    Call SelectObject(hDC, hOldMap)

    Call SetProp(hWnd, FlatMenuOldMap, hMap)
    Call DeleteDC(hDC)
    Call ReleaseDC(GetDesktopWindow, hDCDsk)

    'Debug.Print "Save"
    SaveOld = True

End Function

Private Function FreeOld(ByVal hWnd As Long) As Boolean

  'Debug.Print "FreeOld"

  Dim TempLng As Long

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

    Call DeleteObject(TempLng)
    Call RemoveProp(hWnd, FlatMenuOldMap)

    'Debug.Print "Free"
    FreeOld = True

End Function

Private Function CallWndRetProc_Menu(ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As CWPRETSTRUCT) As Long

  Dim ClassStr As String
  Dim NCCS As NCCALCSIZE_PARAMS

    Select Case nCode
      Case HC_ACTION

        ClassStr = ClassName(lParam.hWnd)

        If ClassStr = WC_Menu Then
            'Debug.Print lParam.Message

            Select Case lParam.message
              Case WM_SPLWND '菜单显示
                'Debug.Print "WM_SPLWND"

                '用SetWindowPos故意设置SWP_FRAMECHANGED
                '这样在WindowProc_Menu中才可以接收WM_NCCALCSIZE消息
                Call SetWindowPos(lParam.hWnd, 0, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOACTIVATE Or SWP_FRAMECHANGED)

              Case WM_SHOWWINDOW '菜单隐藏时恢复
                If lParam.wParam = 0 Then
                    NoSize = True
                    Call SetWindowPos(lParam.hWnd, 0, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOACTIVATE Or SWP_FRAMECHANGED)
                    NoSize = False

                End If

              Case WM_NCCALCSIZE '设置客户区位置

                If lParam.wParam And Not NoSize Then
                    CopyMemory NCCS, ByVal lParam.lParam, Len(NCCS)

                    With NCCS.rgrc(0)
                        .Left = .Left - ShadowSize \ 2
                        .Top = .Top - ShadowSize \ 2
                        .Right = .Right - ShadowSize \ 2
                        .Bottom = .Bottom - ShadowSize \ 2
                    End With 'NCCS.RGRC(0)

                    CopyMemory ByVal lParam.lParam, NCCS, Len(NCCS)

                End If

              Case WM_NCPAINT '再绘制平面边框
                DrawFlatMenu lParam.hWnd

              Case WM_PRINT '这样在选择“动画显示菜单”时也可以正常绘制边框
                DrawFlatMenu lParam.hWnd, lParam.wParam

              Case Else
                '

            End Select '结束lParam.Message判断

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

    End Select '结束nCode判断

    CallWndRetProc_Menu = CallNextHookEx(hHookRet, nCode, wParam, lParam)

End Function

Public Sub DrawFlatMenu(ByVal hWnd As Long, Optional ByVal DrawhDC As Long)

  Dim hDC As Long
  Dim hDCDsk As Long
  Dim WndRect As RECT
  Dim Wi As Long, He As Long
  Dim OldPen As Long
  Dim OldBr As Long
  Dim hDCOld As Long
  Dim hMap As Long
  Dim hOldMap As Long
  Dim hBr As Long
  Dim TempRect As RECT

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

    If DrawhDC Then
        hDC = DrawhDC
      Else 'DRAWHDC = FALSE
        hDC = GetWindowDC(hWnd)
        'Debug.Print hDC
    End If

    hDCDsk = GetWindowDC(GetDesktopWindow)

    '取得窗口大小
    Call GetWindowRect(hWnd, WndRect)

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

    '绘制边框
    OldPen = SelectObject(hDC, CreatePen(vbSolid, 1, EdgeColor))
    OldBr = SelectObject(hDC, GetStockObject(NULL_BRUSH))
    Call Rectangle(hDC, 0, 0, Wi - ShadowSize, He - ShadowSize)
    DeleteObject SelectObject(hDC, OldPen)
    Call SelectObject(hDC, OldBr)

    '绘制阴影
    hDCOld = CreateCompatibleDC(hDC)
    hMap = GetProp(hWnd, FlatMenuOldMap)
    If (hDCOld = 0) Or (hMap = 0) Then
        hBr = CreateSolidBrush(ShadowColor)
        TempRect.Right = Wi
        TempRect.Left = TempRect.Right - ShadowSize
        TempRect.Bottom = He
        TempRect.Top = 0
        Call FillRect(hDC, TempRect, hBr)
        TempRect.Left = 0
        TempRect.Top = TempRect.Bottom - ShadowSize
        Call FillRect(hDC, TempRect, hBr)
        DeleteObject hBr

        If hDCOld Then
            Call DeleteDC(hDCOld)
        End If

      Else 'NOT (HDCOLD...
        hOldMap = SelectObject(hDCOld, hMap)

        BitBlt hDC, Wi - ShadowSize, 0, ShadowSize, He - ShadowSize, hDCOld, Wi - ShadowSize, 0, vbSrcCopy
        BitBlt hDC, 0, He - ShadowSize, Wi, ShadowSize, hDCOld, 0, He - ShadowSize, vbSrcCopy
        If RoundRect Then
            Call SetPixelV(hDC, 0, 0, GetPixel(hDCOld, 0, 0))
            Call SetPixelV(hDC, Wi - ShadowSize - 1, 0, GetPixel(hDCOld, Wi - ShadowSize - 1, 0))
            Call SetPixelV(hDC, 0, He - ShadowSize - 1, GetPixel(hDCOld, 0, He - ShadowSize - 1))
            Call SetPixelV(hDC, Wi - ShadowSize - 1, He - ShadowSize - 1, GetPixel(hDCOld, Wi - ShadowSize - 1, He - ShadowSize - 1))

        End If

        Call SelectObject(hDCOld, hOldMap)
        Call DeleteDC(hDCOld)

    End If

    If DrawhDC Then
      Else 'DRAWHDC = FALSE
        Call ReleaseDC(hWnd, hDC)
    End If
    Call ReleaseDC(GetDesktopWindow, hDCDsk)

End Sub

':) Ulli's VB Code Formatter V2.10.8 (2003-01-01 13:56:42) 131 + 437 = 568 Lines