moddrawingxp.bas

很好一套库存管理

Attribute VB_Name = "modDrawing"
Option Explicit
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" ( _
    ByVal dwFlags As Long, lpSource As Any, dwMessageID As Long, _
    ByVal dwLanguageID As Long, lpBuffer As String, _
    ByVal nSize As Long, Arguments As Long) As Long
' =====================================================================
' APIs used primarily for drawing/graphics
' =====================================================================
Private Declare Function StretchBlt Lib "gdi32" ( _
        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 dwRop As Long) _
    As Long
Public Declare Function DrawState Lib "user32" Alias "DrawStateA" (ByVal hDC As Long, ByVal hBR As Long, ByVal lpDrawStateProc As Long, ByVal lParam As Long, ByVal wParam As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal fuFlags As Long) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CopyImage Lib "user32" (ByVal Handle As Long, ByVal ImageType As Long, ByVal newWidth As Long, _
    ByVal NewHeight As Long, ByVal lFlags As Long) As Long
Private Declare Function OleTranslateColor Lib "oleaut32.dll" _
     (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hDC As Long, _
     ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Public Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Public Declare Function GetTextColor Lib "gdi32" (ByVal hDC As Long) As Long
Public Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Public Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Public Const NEWTRANSPARENT = 3 'use with SetBkMode()
Private Declare Function CreatePen Lib "gdi32" _
     (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" _
     (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" _
     (ByVal hDC As Long, ByVal x As Long, ByVal y 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
' following public functions/types may not be used in these modules but are
' used in my CodeSafe program & are here for organizational reasons
Public Declare Function DrawIconEx Lib "user32" (ByVal hDC As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Integer
Public Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As NONCLIENTMETRICS, ByVal fuWinIni As Long) As Long
Public Declare Function GetSysColor Lib "user32" (ByVal nIndex 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 CreateBitmap Lib "gdi32" (ByVal nWidth As Long, _
     ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Public Declare Function GetBkColor Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function PatBlt Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop 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
Public Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Public Const DT_CALCRECT = &H400
Public Const DT_LEFT = &H0
Public Const DT_SINGLELINE = &H20
Public Const DT_NOCLIP = &H100
Private Const DT_CENTER = &H1

' Types used for fonts & images
Public Type POINTAPI
    x As Long
    y As Long
End Type
Public Type LOGFONT
  lfHeight As Long
  lfWidth As Long
  lfEscapement As Long
  lfOrientation As Long
  lfWeight As Long
  lfItalic As Byte '0=false; 255=true
  lfUnderline As Byte '0=f; 255=t
  lfStrikeOut As Byte '0=f; 255=t
  lfCharSet As Byte
  lfOutPrecision As Byte
  lfClipPrecision As Byte
  lfQuality As Byte
  lfPitchAndFamily As Byte
  lfFaceName As String * 32
End Type
Public Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
Private Type TEXTMETRIC
  tmHeight As Long
  tmAscent As Long
  tmDescent As Long
  tmInternalLeading As Long
  tmExternalLeading As Long
  tmAveCharWidth As Long
  tmMaxCharWidth As Long
  tmWeight As Long
  tmOverhang As Long
  tmDigitizedAspectX As Long
  tmDigitizedAspectY As Long
  tmFirstChar As Byte
  tmLastChar As Byte
  tmDefaultChar As Byte
  tmBreakChar As Byte
  tmItalic As Byte
  tmUnderlined As Byte
  tmStruckOut As Byte
  tmPitchAndFamily As Byte
  tmCharSet As Byte
End Type
Private Type NONCLIENTMETRICS
    cbSize As Long
    iBorderWidth As Long
    iScrollWidth As Long
    iScrollHeight As Long
    iCaptionWidth As Long
    iCaptionHeight As Long
    lfCaptionFont As LOGFONT
    iSMCaptionWidth As Long
    iSMCaptionHeight As Long
    lfSMCaptionFont As LOGFONT
    iMenuWidth As Long
    iMenuHeight As Long
    lfMenuFont As LOGFONT
    lfStatusFont As LOGFONT
    lfMessageFont As LOGFONT
End Type
' Other constants used for graphics
Private Const WHITENESS = &HFF0062
Private Const MAGICROP = &HB8074A
Private Const DSna = &H220326 '0x00220326
'Color constants for GetSysColor
Public Enum ColConst
    COLOR_ACTIVEBORDER = 10
    COLOR_ACTIVECAPTION = 2
    COLOR_ADJ_MAX = 100
    COLOR_ADJ_MIN = -100
    COLOR_APPWORKSPACE = 12
    COLOR_BACKGROUND = 1
    COLOR_BTNFACE = 15
    COLOR_BTNHIGHLIGHT = 20
    COLOR_BTNLIGHT = 22
    COLOR_BTNSHADOW = 16
    COLOR_BTNTEXT = 18
    COLOR_CAPTIONTEXT = 9
    COLOR_GRAYTEXT = 17
    COLOR_HIGHLIGHT = 13
    COLOR_HIGHLIGHTTEXT = 14
    COLOR_INACTIVEBORDER = 11
    COLOR_INACTIVECAPTION = 3
    COLOR_INACTIVECAPTIONTEXT = 19
    COLOR_MENU = 4
    COLOR_MENUTEXT = 7
    COLOR_SCROLLBAR = 0
    COLOR_WINDOW = 5
    COLOR_WINDOWFRAME = 6
    COLOR_WINDOWTEXT = 8
End Enum
' local variables
Private m_hDC As Long               ' reference to DC being drawn in
Private m_Font(0 To 1) As Long      ' local copy of menu font
Private m_FontOld As Long           ' font of DC prior to replacing with menu font

Public Sub DrawRect(ByVal x1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long)
' =====================================================================
'   Simply draws a rectangle using the current DC's background color
' =====================================================================
     If m_hDC = 0 Then Exit Sub
     Call Rectangle(m_hDC, x1, Y1, X2, Y2)
End Sub

Public Function GetPen(ByVal nWidth As Long, ByVal Clr As Long) As Long
' =====================================================================
' Creates a colored pen for drawing
' =====================================================================
    GetPen = CreatePen(0, nWidth, Clr)
End Function

Public Sub DrawCaption(ByVal x As Long, ByVal y As Long, tRect As RECT, _
    ByVal hStr As String, hAccel As String, iTab As Integer, _
    ByVal Clr As Long, Optional bCenter As Boolean = False, _
    Optional iOffset As Integer = 0)
    
' =====================================================================
' Prints text to current DC in the coodinates & colors provided
' =====================================================================
    If m_hDC = 0 Then Exit Sub
    'Equivalent to setting a form's property FontTransparent = True
    SetBkMode m_hDC, NEWTRANSPARENT
    Dim OT As Long, x1 As Long
    ' set text color and set x,y coordinates for printing
    OT = GetTextColor(m_hDC)
    SetTextColor m_hDC, Clr
    x1 = tRect.Right
    ' print the caption/text
    If bCenter Then
        DrawText m_hDC, hStr, Len(hStr), tRect, DT_NOCLIP Or DT_CALCRECT Or DT_CALCRECT Or DT_SINGLELINE
        tRect.Left = (x1 - iOffset - tRect.Right) \ 2 + iOffset
        tRect.Right = tRect.Left + tRect.Right
    Else
        tRect.Left = x + iOffset
    End If
    tRect.Top = y
    tRect.Bottom = tRect.Bottom + y
    DrawText m_hDC, hStr, Len(hStr), tRect, DT_SINGLELINE Or DT_NOCLIP Or DT_LEFT
    If Len(hAccel) Then
        ' here we will print an acceleraor key if needed
        tRect.Left = tRect.Left + iTab - iOffset
        tRect.Top = y
        DrawText m_hDC, hAccel, Len(hAccel), tRect, DT_LEFT Or DT_NOCLIP Or DT_SINGLELINE
    End If
    'Restore old text color
    SetTextColor m_hDC, OT
End Sub

Public Property Let TargethDC(ByVal vNewValue As Long)
' =====================================================================
' Maintain a local reference to the DC being drawn in
' simply prevents having to pass it to each call to a drawing routine
' =====================================================================
     m_hDC = vNewValue
End Property

Public Sub ThreeDbox(ByVal x1 As Long, ByVal Y1 As Long, _
ByVal X2 As Long, ByVal Y2 As Long, bSelected As Boolean, _
Optional Sunken As Boolean = False)
' =====================================================================
'   Draw/erase a raised/sunken box around the specified coordinates.
' =====================================================================

     If m_hDC = 0 Then Exit Sub

     Dim CurPen As Long, OldPen As Long
     Dim dm As POINTAPI, iOffset As Integer
     
     ' select colors, offset when set indicates erasing
     iOffset = Abs(CInt(bSelected)) + 1
     If Sunken = False Then
         CurPen = GetPen(1, GetSysColor(Choose(iOffset, COLOR_MENU, COLOR_BTNHIGHLIGHT)))
     Else
          CurPen = GetPen(1, GetSysColor(Choose(iOffset, COLOR_MENU, COLOR_BTNSHADOW)))
     End If
     OldPen = SelectObject(m_hDC, CurPen)
     
     'First - Light Line
     MoveToEx m_hDC, x1 + 2, Y2, dm
     LineTo m_hDC, x1 + 2, Y1
     LineTo m_hDC, X2 - 2, Y1

     SelectObject m_hDC, OldPen
     DeleteObject CurPen
     ' Next - Dark line
     If Sunken = False Then
          CurPen = GetPen(1, GetSysColor(Choose(iOffset, COLOR_MENU, COLOR_BTNSHADOW)))
     Else
          CurPen = GetPen(1, GetSysColor(Choose(iOffset, COLOR_MENU, COLOR_BTNHIGHLIGHT)))
     End If
     OldPen = SelectObject(m_hDC, CurPen)
     
     MoveToEx m_hDC, X2 - 2, Y1, dm
     LineTo m_hDC, X2 - 2, Y2
     LineTo m_hDC, x1 + 2, Y2

     ' Replace pen & delete temp pen
     SelectObject m_hDC, OldPen
     DeleteObject CurPen
End Sub

Public Sub DrawMenuIcon(lImageHdl As Long, ImageType As Long, _
    rt As RECT, bdisabled As Boolean, Optional bInColor As Boolean = True, _
    Optional bForceTransparency As Long = 0, Optional iOffset As Integer = 0, _
    Optional yOffset As Integer, Optional IMGwidth As Integer = 16, _
    Optional IMGheight As Integer = 16, Optional lMask As Long = -1)
' =====================================================================
'   Draws imagelist image on destined DC
' =====================================================================

' ensure the requested image exists
If lImageHdl = 0 Then Exit Sub

Dim lImageSmall As Long, lDrawType As Long, lImageType As Long
Const DSS_DISABLED = &H20
Const DSS_NORMAL = &H0
Const DSS_BITMAP = &H4
Const DSS_ICON = &H3
Const CI_BITMAP = &H0
Const CI_ICON = &H1
Dim rcImage As RECT

If ImageType < 2 Then
    lDrawType = DSS_BITMAP
    lImageType = CI_BITMAP
Else
    lDrawType = DSS_ICON
    lImageType = CI_ICON
End If
lImageSmall = CopyImage(lImageHdl, lImageType, IMGwidth, IMGheight, DSS_NORMAL)
If lImageSmall = 0 Then ' failed to make a copy from the imagetype passed, try the other settings
    If lDrawType = DSS_BITMAP Then
        lDrawType = DSS_ICON
        lImageType = CI_ICON
    Else
        lDrawType = DSS_BITMAP
        lImageType = CI_BITMAP
    End If
    lImageSmall = CopyImage(lImageHdl, lImageType, IMGwidth, IMGheight, DSS_NORMAL)
End If
If lImageSmall = 0 Then Exit Sub

If bdisabled = False Then
    ' if not disabled, then straightforward extraction/drawing on coords
    If ((lImageType = CI_ICON And bForceTransparency < 2) Or bForceTransparency = 2) Then
        DrawState m_hDC, 0, 0, lImageSmall, 0, rt.Left + iOffset, rt.Top + yOffset, 0, 0, lDrawType
    Else
        MakeTransparentBitmap lImageSmall, rt.Left + iOffset, rt.Top + yOffset, IMGwidth, IMGheight, , , lMask
    End If
    DeleteObject lImageSmall
Else
' =====================================================================
'   This function is from Paul DiLascia's DrawEmbossed function
'   which draws colored disabled pictures.
'   To be fair to him, I modified several lines of code so
'   it is customized for CodeSafe & should it fail -- not his fault
' =====================================================================

'  // create mono or color bitmap
    Dim hBitmap As Long
    If bInColor Then
        hBitmap& = CreateCompatibleBitmap(m_hDC&, IMGwidth, IMGheight)
    Else
        hBitmap& = CreateBitmap(IMGwidth, IMGheight, 1, 1, vbNull)
    End If
'  // draw image into memory DC--fill BG white first
'  // create memory dc