mybutton.ctl

VS平台内存补丁

Private Function pvRenderBitmapGrayscale(ByVal Dest_hDC As Long, _
                                         ByVal hBitmap As Long, _
                                         Optional ByVal Dest_X As Long, _
                                         Optional ByVal Dest_Y As Long, _
                                         Optional ByVal Srce_X As Long, _
                                         Optional ByVal Srce_Y As Long) As Boolean
  On Error GoTo pvRenderBitmapGrayscale_Error

  Dim TempBITMAP  As BITMAP
  Dim hScreen     As Long
  Dim hDC_Temp    As Long
  Dim hBMP_Prev   As Long
  Dim MyCounterX  As Long
  Dim MyCounterY  As Long
  Dim NewColor    As Long
  Dim hNewPicture As Long
  Dim DeletePic   As Boolean

  ' Make sure parameters passed are valid
  If Dest_hDC = 0 Or hBitmap = 0 Then Exit Function
  ' Get the handle to the screen DC
  hScreen = GetDC(0)

  If hScreen = 0 Then Exit Function
  ' Create a memory DC to work with the picture
  hDC_Temp = CreateCompatibleDC(hScreen)

  If hDC_Temp = 0 Then GoTo CleanUp
  ' If the user specifies NOT to alter the original, then make a copy of it to use
  DeletePic = False
  hNewPicture = hBitmap
  ' Select the bitmap into the DC
  hBMP_Prev = SelectObject(hDC_Temp, hNewPicture)

  ' Get the height / width of the bitmap in pixels
  If GetObjectAPI(hNewPicture, Len(TempBITMAP), TempBITMAP) = 0 Then GoTo CleanUp
  If TempBITMAP.bmHeight <= 0 Or TempBITMAP.bmWidth <= 0 Then GoTo CleanUp

  ' Loop through each pixel and conver it to it's grayscale equivelant
  For MyCounterX = 0 To TempBITMAP.bmWidth - 1
    For MyCounterY = 0 To TempBITMAP.bmHeight - 1
      NewColor = GetPixel(hDC_Temp, MyCounterX, MyCounterY)

      If NewColor <> -1 Then

        Select Case NewColor
            ' If the color is already a grey shade, no need to convert it
          Case vbBlack, vbWhite, &H101010, &H202020, &H303030, &H404040, &H505050, &H606060, &H707070, &H808080, &HA0A0A0, &HB0B0B0, &HC0C0C0, &HD0D0D0, &HE0E0E0, &HF0F0F0
            NewColor = NewColor
          Case Else
            NewColor = 0.33 * (NewColor Mod 256) + 0.59 * ((NewColor \ 256) Mod 256) + 0.11 * ((NewColor \ 65536) Mod 256)
            NewColor = RGB(NewColor, NewColor, NewColor)
        End Select

        SetPixelV hDC_Temp, MyCounterX, MyCounterY, NewColor
      End If

    Next 'MyCounterY
  Next 'MyCounterX

  ' Display the picture on the specified hDC
  BitBlt Dest_hDC, Dest_X, Dest_Y, TempBITMAP.bmWidth, TempBITMAP.bmHeight, hDC_Temp, Srce_X, Srce_Y, vbSrcCopy
  pvRenderBitmapGrayscale = True
CleanUp:
  ReleaseDC 0, hScreen: hScreen = 0
  SelectObject hDC_Temp, hBMP_Prev
  DeleteDC hDC_Temp: hDC_Temp = 0

  If DeletePic = True Then
    DeleteObject hNewPicture
    hNewPicture = 0
  End If

  Exit Function

pvRenderBitmapGrayscale_Error:
End Function

Private Function pvCreateIconFromBMP(ByVal hBMP_Mask As Long, _
                                     ByVal hBMP_Image As Long) As Long
  On Error GoTo pvCreateIconFromBMP_Error

  Dim TempICONINFO As ICONINFO

  If hBMP_Mask = 0 Or hBMP_Image = 0 Then Exit Function
  TempICONINFO.fIcon = 1
  TempICONINFO.hbmMask = hBMP_Mask
  TempICONINFO.hbmColor = hBMP_Image
  pvCreateIconFromBMP = CreateIconIndirect(TempICONINFO)
  Exit Function

pvCreateIconFromBMP_Error:
End Function

'*************************************************************
'
'   Private Auxiliar Subs
'
'*************************************************************
'draw a Line Using API call's
Private Sub APILine(X1 As Long, _
                    Y1 As Long, _
                    X2 As Long, _
                    Y2 As Long, _
                    lcolor As Long)
  'Use the API LineTo for Fast Drawing
  On Error GoTo APILine_Error

  Dim pt As POINT
  Dim hPen As Long, hPenOld As Long
  hPen = CreatePen(0, 1, lcolor)
  hPenOld = SelectObject(UserControl.hDC, hPen)
  MoveToEx UserControl.hDC, X1, Y1, pt
  LineTo UserControl.hDC, X2, Y2
  SelectObject UserControl.hDC, hPenOld
  DeleteObject hPen
  Exit Sub

APILine_Error:
End Sub

' full version of APILine
Private Sub APILineEx(lhdcEx As Long, _
                      X1 As Long, _
                      Y1 As Long, _
                      X2 As Long, _
                      Y2 As Long, _
                      lcolor As Long)
  'Use the API LineTo for Fast Drawing
  On Error GoTo APILineEx_Error

  Dim pt As POINT
  Dim hPen As Long, hPenOld As Long
  hPen = CreatePen(0, 1, lcolor)
  hPenOld = SelectObject(lhdcEx, hPen)
  MoveToEx lhdcEx, X1, Y1, pt
  LineTo lhdcEx, X2, Y2
  SelectObject lhdcEx, hPenOld
  DeleteObject hPen
  Exit Sub

APILineEx_Error:
End Sub

Private Sub ApiFillRect(hDC As Long, _
                        rc As RECT, _
                        Color As Long)
  On Error GoTo APIFillRect_Error

  Dim NewBrush As Long
  NewBrush& = CreateSolidBrush(Color&)
  Call FillRect(hDC&, rc, NewBrush&)
  Call DeleteObject(NewBrush&)
  Exit Sub

APIFillRect_Error:
End Sub

Private Sub APIFillRectByCoords(hDC As Long, _
                                ByVal X As Long, _
                                ByVal Y As Long, _
                                ByVal w As Long, _
                                ByVal H As Long, _
                                Color As Long)
  On Error GoTo APIFillRectByCoords_Error

  Dim NewBrush As Long
  Dim tmpRect As RECT
  NewBrush& = CreateSolidBrush(Color&)
  SetRect tmpRect, X, Y, X + w, Y + H
  Call FillRect(hDC&, tmpRect, NewBrush&)
  Call DeleteObject(NewBrush&)
  Exit Sub

APIFillRectByCoords_Error:
End Sub

Private Function ApiRectangle(ByVal hDC As Long, _
                              ByVal X As Long, _
                              ByVal Y As Long, _
                              ByVal w As Long, _
                              ByVal H As Long, _
                              Optional lcolor As OLE_COLOR = -1) As Long
  On Error GoTo APIRectangle_Error

  Dim hPen As Long, hPenOld As Long
  Dim pt As POINT
  hPen = CreatePen(0, 1, lcolor)
  hPenOld = SelectObject(hDC, hPen)
  MoveToEx hDC, X, Y, pt
  LineTo hDC, X + w, Y
  LineTo hDC, X + w, Y + H
  LineTo hDC, X, Y + H
  LineTo hDC, X, Y
  SelectObject hDC, hPenOld
  DeleteObject hPen
  Exit Function

APIRectangle_Error:
End Function

'Private Sub DrawCtlEdgeByRect(hdc As Long, _
'                              rt As RECT, _
'                              Optional Style As Long = EDGE_RAISED, _
'                              Optional Flags As Long = BF_RECT)
'  On Error GoTo DrawCtlEdgeByRect_Error
'
'  DrawEdge hdc, rt, Style, Flags
'  Exit Sub
'
'DrawCtlEdgeByRect_Error:
'End Sub

Private Sub DrawCtlEdge(hDC As Long, _
                        ByVal X As Single, _
                        ByVal Y As Single, _
                        ByVal w As Single, _
                        ByVal H As Single, _
                        Optional Style As Long = EDGE_RAISED, _
                        Optional ByVal flags As Long = BF_RECT)
  On Error GoTo DrawCtlEdge_Error

  Dim R As RECT

  With R
    .Left = X
    .Top = Y
    .Right = X + w
    .Bottom = Y + H
  End With

  DrawEdge hDC, R, Style, flags
  Exit Sub

DrawCtlEdge_Error:
End Sub

'Blend two colors
Private Function BlendColors(ByVal lcolor1 As Long, _
                             ByVal lcolor2 As Long)
  On Error GoTo BlendColors_Error

  BlendColors = RGB(((lcolor1 And &HFF) + (lcolor2 And &HFF)) / 2, (((lcolor1 \ &H100) And &HFF) + ((lcolor2 \ &H100) And &HFF)) / 2, (((lcolor1 \ &H10000) And &HFF) + ((lcolor2 \ &H10000) And &HFF)) / 2)
  Exit Function

BlendColors_Error:
End Function

'System color code to long rgb
Private Function TranslateColor(ByVal lcolor As Long) As Long
  On Error GoTo TranslateColor_Error

  If OleTranslateColor(lcolor, 0, TranslateColor) Then
    TranslateColor = -1
  End If

  Exit Function

TranslateColor_Error:
End Function


Private Function MSOXPShiftColor(ByVal theColor As Long, _
                                 Optional ByVal Base As Long = &HB0) As Long
  On Error GoTo MSOXPShiftColor_Error

  Dim Red As Long, Blue As Long, Green As Long
  Dim Delta As Long
  Blue = ((theColor \ &H10000) Mod &H100)
  Green = ((theColor \ &H100) Mod &H100)
  Red = (theColor And &HFF)
  Delta = &HFF - Base
  Blue = Base + Blue * Delta \ &HFF
  Green = Base + Green * Delta \ &HFF
  Red = Base + Red * Delta \ &HFF

  If Red > 255 Then Red = 255
  If Green > 255 Then Green = 255
  If Blue > 255 Then Blue = 255
  MSOXPShiftColor = Red + 256& * Green + 65536 * Blue
  Exit Function

MSOXPShiftColor_Error:
End Function


'Offset a color
Private Function OffsetColor(lcolor As OLE_COLOR, _
                             lOffset As Long) As OLE_COLOR
  On Error GoTo OffsetColor_Error

  Dim lRed As OLE_COLOR
  Dim lGreen As OLE_COLOR
  Dim lBlue As OLE_COLOR
  Dim lR As OLE_COLOR, lg As OLE_COLOR, lb As OLE_COLOR
  lR = (lcolor And &HFF)
  lg = ((lcolor And 65280) \ 256)
  lb = ((lcolor) And 16711680) \ 65536
  lRed = (lOffset + lR)
  lGreen = (lOffset + lg)
  lBlue = (lOffset + lb)

  If lRed > 255 Then lRed = 255
  If lRed < 0 Then lRed = 0
  If lGreen > 255 Then lGreen = 255
  If lGreen < 0 Then lGreen = 0
  If lBlue > 255 Then lBlue = 255
  If lBlue < 0 Then lBlue = 0
  OffsetColor = RGB(lRed, lGreen, lBlue)
  Exit Function

OffsetColor_Error:
End Function

Private Sub DrawCaption()
  On Error GoTo DrawCaption_Error

  Dim lcolor As Long, ltmpColor As Long

  If Not m_bUseCustomColors Then
    If m_iState <> statedisabled Then
      lcolor = GetSysColor(COLOR_BTNTEXT)
    Else
      lcolor = TranslateColor(vbGrayText)
    End If

  Else

    Select Case m_iState
      Case statenormal
        lcolor = m_lFontColor
      Case statedisabled