mgdi.bas

仿照windows XP的菜单控件,VB环境的,可以学习用

Public Sub BoxDC(ByVal HDC As Long, ByVal x As Long, ByVal Y As Long, ByVal W As Long, ByVal H As Long, Optional Color As OLE_COLOR = vbButtonFace, Optional Fill As OLE_COLOR = -1)
 Dim hPen As Long, hPenOld As Long
 'Fill
 If Fill <> -1 Then BoxSolidDC HDC, x, Y, W, H, Fill
 'Box
 hPen = CreatePen(0, 1, TranslateColor(Color))
 hPenOld = SelectObject(HDC, hPen)
 MoveToEx HDC, x + W - 1, Y, PT
 LineTo HDC, x, Y
 LineTo HDC, x, Y + H - 1
 LineTo HDC, x + W - 1, Y + H - 1
 LineTo HDC, x + W - 1, Y
 SelectObject HDC, hPenOld
 DeleteObject hPen
 DeleteObject hPenOld
End Sub

Public Function BoxSolidDC(ByVal HDC As Long, ByVal x As Long, ByVal Y As Long, ByVal W As Long, ByVal H As Long, Optional ByVal Fill As OLE_COLOR = vbButtonFace)
 Dim hBrush As Long
 Dim R As Rect
 hBrush = CreateSolidBrush(TranslateColor(Fill))
 With R
  .Left = x
  .Top = Y
  .Right = x + W - 1
  .Bottom = Y + H - 1
 End With
 FillRect HDC, R, hBrush
 DeleteObject hBrush
End Function

Public Sub BoxRect3DDC(ByVal HDC As Long, R As Rect, Optional Highlight As OLE_COLOR = vb3DHighlight, Optional Shadow As OLE_COLOR = vb3DShadow, Optional Fill As OLE_COLOR = -1)
 Box3DDC HDC, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, Highlight, Shadow, Fill
End Sub

Public Sub PaintText(ByVal HDC As Long, ByVal Text$, ByVal x As Single, ByVal Y As Single, ByVal W As Single, ByVal H As Single, Optional ByVal Flags As Long = DT_LEFT)
 Dim R As Rect
 With R
  .Left = x
  .Top = Y
  .Right = x + W
  .Bottom = Y + H
 End With
 DrawText HDC, Text$, -1, R, Flags
End Sub


Public Sub DrawFocus(ByVal HDC As Long, ByVal x As Long, ByVal Y As Long, ByVal W As Long, ByVal H As Long)
 Dim R As Rect
 With R
  .Left = x
  .Top = Y
  .Right = x + W
  .Bottom = Y + H
 End With
 DrawFocusRect HDC, R
 
End Sub


Public Function MouseUnder(HWND As Long) As Boolean
    Dim ptMouse As POINTAPI
    GetCursorPos ptMouse
    If WindowFromPoint(ptMouse.x, ptMouse.Y) = HWND Then
       MouseUnder = True
    Else
       MouseUnder = False
    End If

End Function





Public Sub SetPosition(frm As Form, HWND As Long)

Dim rc As Rect
Dim SX As Long
Dim SY As Long

    SY = Screen.TwipsPerPixelY
    SX = Screen.TwipsPerPixelX
    
    GetWindowRect HWND, rc
    If frm.Height + (rc.Bottom + 1) * SY > Screen.Height Then
        rc.Top = (rc.Top - 1) * SY - frm.Height
    Else
        rc.Top = (rc.Bottom + 1) * SY
    End If
    
    If frm.Width + rc.Left * SX > Screen.Width Then
        rc.Left = Screen.Width - frm.Width - SX
    Else
        rc.Left = rc.Left * SX
    End If
    
    frm.Move rc.Left, rc.Top
   
End Sub

Public Function InflateRect(Rect As Rect, Value As Integer) As Integer
    Rect.Top = Rect.Top - Value
    Rect.Left = Rect.Left - Value
    Rect.Bottom = Rect.Bottom + Value
    Rect.Right = Rect.Right + Value
End Function

Public Function DeflateRect(Rect As Rect, Value As Integer) As Integer
    Rect.Top = Rect.Top + Value
    Rect.Left = Rect.Left + Value
    Rect.Bottom = Rect.Bottom - Value
    Rect.Right = Rect.Right - Value
End Function

Public Sub zCopyDC(ByVal lHDCDest As Long, ByVal lHDCSource As Long, ByRef tR As Rect, Top As Integer, Left As Integer)
    With tR
        BitBlt lHDCDest, .Left, .Top, .Right - .Left, .Bottom - .Top, lHDCSource, .Left, .Top, vbSrcCopy
    End With
End Sub

Public Sub BoxRect3DDCex(ByVal HDC As Long, R As Rect, Optional Highlight As OLE_COLOR = vb3DHighlight, Optional Shadow As OLE_COLOR = vb3DShadow, Optional Fill As OLE_COLOR = -1)
 Box3DDCex HDC, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, Highlight, Shadow, Fill
End Sub

Public Sub Box3DDCex(ByVal HDC As Long, ByVal x As Long, ByVal Y As Long, ByVal W As Long, ByVal H As Long, Optional Highlight As OLE_COLOR = vb3DHighlight, Optional Shadow As OLE_COLOR = vb3DShadow, Optional Fill As OLE_COLOR = -1)
 Dim hPen As Long, hPenOld As Long
 'Fill
 If Fill <> -1 Then BoxSolidDC HDC, x, Y, W, H, Fill
 'Highlight
 hPen = CreatePen(0, 1, TranslateColor(Highlight))
 hPenOld = SelectObject(HDC, hPen)
 MoveToEx HDC, x + W - 1, Y, PT
 LineTo HDC, x, Y
 LineTo HDC, x, Y + H - 1
 SelectObject HDC, hPenOld
 DeleteObject hPen
 DeleteObject hPenOld
 'Shadow
 hPen = CreatePen(0, 1, TranslateColor(Shadow))
 hPenOld = SelectObject(HDC, hPen)
 MoveToEx HDC, x, Y + H - 1, PT
 LineTo HDC, x + W - 1, Y + H - 1
 LineTo HDC, x + W - 1, Y - 1
 SelectObject HDC, hPenOld
 DeleteObject hPen
 DeleteObject hPenOld
End Sub

Public Sub DrawMenuShadow( _
    ByVal HWND As Long, _
    ByVal HDC As Long, _
    ByVal xOrg As Long, _
    ByVal yOrg As Long)
     
    Dim hDcDsk As Long
    Dim Rec As Rect
    Dim winW As Long, winH As Long
    Dim x As Long, Y As Long, c As Long
     
    '- Get the size of the menu...
    GetWindowRect HWND, Rec
    winW = Rec.Right - Rec.Left
    winH = Rec.Bottom - Rec.Top
     
    ' - Get the desktop hDC...
    hDcDsk = GetWindowDC(GetDesktopWindow)
     
    ' - Simulate a shadow on right edge...
    For x = 1 To 4
        For Y = 0 To 3
            c = GetPixel(hDcDsk, xOrg + winW - x, yOrg + Y)
            SetPixel HDC, winW - x, Y, c
        Next Y
        For Y = 4 To 7
            c = GetPixel(hDcDsk, xOrg + winW - x, yOrg + Y)
            SetPixel HDC, winW - x, Y, pMask(3 * x * (Y - 3), c)
        Next Y
        For Y = 8 To winH - 5
            c = GetPixel(hDcDsk, xOrg + winW - x, yOrg + Y)
            SetPixel HDC, winW - x, Y, pMask(15 * x, c)
        Next Y
        For Y = winH - 4 To winH - 1
            c = GetPixel(hDcDsk, xOrg + winW - x, yOrg + Y)
            SetPixel HDC, winW - x, Y, pMask(3 * x * -(Y - winH), c)
        Next Y
    Next x
     
    ' - Simulate a shadow on the bottom edge...
    For Y = 1 To 4
        For x = 0 To 3
            c = GetPixel(hDcDsk, xOrg + x, yOrg + winH - Y)
            SetPixel HDC, x, winH - Y, c
        Next x
        For x = 4 To 7
            c = GetPixel(hDcDsk, xOrg + x, yOrg + winH - Y)
            SetPixel HDC, x, winH - Y, pMask(3 * (x - 3) * Y, c)
        Next x
        For x = 8 To winW - 5
            c = GetPixel(hDcDsk, xOrg + x, yOrg + winH - Y)
            SetPixel HDC, x, winH - Y, pMask(15 * Y, c)
        Next x
    Next Y
     
    ' - Release the desktop hDC...
    ReleaseDC GetDesktopWindow, hDcDsk

End Sub

' - Function pMask splits a color
' into its RGB components and
' transforms the color using
' a scale 0..255
Private Function pMask( _
    ByVal lScale As Long, _
    ByVal lColor As Long) As Long
     
    Dim R As Byte
    Dim G As Byte
    Dim B As Byte
     
    Long2RGB lColor, R, G, B
     
    R = pTransform(lScale, R)
    G = pTransform(lScale, G)
    B = pTransform(lScale, B)
     
    pMask = RGB(R, G, B)
     
End Function

' - Function pTransform converts
' a RGB subcolor using a scale
' where 0 = 0 and 255 = lScale
Private Function pTransform( _
    ByVal lScale As Long, _
    ByVal lColor As Long) As Long
     
    pTransform = lColor - Int(lColor * lScale / 255)
End Function

Public Sub Long2RGB(LongColor As Long, R As Byte, G As Byte, B As Byte)
    On Error Resume Next
    ' convert to hex using vb's hex function
    '     , then use the hex2rgb function
    Hex2RGB (Hex(LongColor)), R, G, B
    'Debug.Print r, g, b
End Sub

Public Sub Hex2RGB(strHexColor As String, R As Byte, G As Byte, B As Byte)
    Dim HexColor As String
    Dim I As Byte
    On Error Resume Next
    ' make sure the string is 6 characters l
    '     ong
    ' (it may have been given in &H###### fo
    '     rmat, we want ######)
    strHexColor = Right((strHexColor), 6)
    ' however, it may also have been given a
    '     s or #***** format, so add 0's in front


    For I = 1 To (6 - Len(strHexColor))
        HexColor = HexColor & "0"
    Next
    HexColor = HexColor & strHexColor
    ' convert each set of 2 characters into
    '     bytes, using vb's cbyte function
    R = CByte("&H" & Right$(HexColor, 2))
    G = CByte("&H" & Mid$(HexColor, 3, 2))
    B = CByte("&H" & Left$(HexColor, 2))
End Sub