mybutton.ctl

VS平台内存补丁

Private Sub zAddMsg(ByVal uMsg As Long, _
                    ByRef aMsgTbl() As Long, _
                    ByRef nMsgCnt As Long, _
                    ByVal When As eMsgWhen, _
                    ByVal nAddr As Long)
  On Error GoTo zAddMsg_Error

  Dim nEntry  As Long 'Message table entry index
  Dim nOff1   As Long 'Machine code buffer offset 1
  Dim nOff2   As Long 'Machine code buffer offset 2

  If uMsg = ALL_MESSAGES Then 'If all messages
    nMsgCnt = ALL_MESSAGES 'Indicates that all messages will callback
  Else 'Else a specific message number

    Do While nEntry < nMsgCnt 'For each existing entry. NB will skip if nMsgCnt = 0
      nEntry = nEntry + 1

      If aMsgTbl(nEntry) = 0 Then 'This msg table slot is a deleted entry
        aMsgTbl(nEntry) = uMsg 'Re-use this entry
        Exit Sub 'Bail

      ElseIf aMsgTbl(nEntry) = uMsg Then 'The msg is already in the table!
        Exit Sub 'Bail

      End If

    Loop 'Next 'entry

    nMsgCnt = nMsgCnt + 1 'New slot required, bump the table entry count
    ReDim Preserve aMsgTbl(1 To nMsgCnt) As Long 'Bump the size of the table.
    aMsgTbl(nMsgCnt) = uMsg 'Store the message number in the table
  End If

  If When = eMsgWhen.MSG_BEFORE Then 'If before
    nOff1 = PATCH_04 'Offset to the Before table
    nOff2 = PATCH_05 'Offset to the Before table entry count
  Else 'Else after
    nOff1 = PATCH_08 'Offset to the After table
    nOff2 = PATCH_09 'Offset to the After table entry count
  End If

  If uMsg <> ALL_MESSAGES Then
    Call zPatchVal(nAddr, nOff1, VarPtr(aMsgTbl(1))) 'Address of the msg table, has to be re-patched because Redim Preserve will move it in memory.
  End If

  Call zPatchVal(nAddr, nOff2, nMsgCnt) 'Patch the appropriate table entry count
  Exit Sub

zAddMsg_Error:
End Sub

'Return the memory address of the passed function in the passed dll
Private Function zAddrFunc(ByVal sDLL As String, _
                           ByVal sProc As String) As Long
  On Error GoTo zAddrFunc_Error

  zAddrFunc = GetProcAddress(GetModuleHandleA(sDLL), sProc)
  '  Debug.Assert zAddrFunc                                                                'You may wish to comment out this line if you're using vb5 else the EbMode GetProcAddress will stop here everytime because we look for vba6.dll first
  Exit Function

zAddrFunc_Error:
End Function


'Get the sc_aSubData() array index of the passed hWnd
Private Function zIdx(ByVal lng_hWnd As Long, _
                      Optional ByVal bAdd As Boolean = False) As Long
  'Get the upper bound of sc_aSubData() - If you get an error here, you're probably Subclass_AddMsg-ing before Subclass_Start
  On Error GoTo zIdx_Error

  zIdx = UBound(sc_aSubData)

  Do While zIdx >= 0 'Iterate through the existing sc_aSubData() elements

    With sc_aSubData(zIdx)

      If .hwnd = lng_hWnd Then

        'If the hWnd of this element is the one we're looking for
        If Not bAdd Then 'If we're searching not adding
          Exit Function 'Found

        End If

      ElseIf .hwnd = 0 Then 'If this an element marked for reuse.

        If bAdd Then 'If we're adding
          Exit Function 'Re-use it

        End If
      End If

    End With

    zIdx = zIdx - 1 'Decrement the index
  Loop

  'If we exit here, we're returning -1, no freed elements were found
  Exit Function

zIdx_Error:
End Function

'Patch the machine code buffer at the indicated offset with the relative address to the target address.
Private Sub zPatchRel(ByVal nAddr As Long, _
                      ByVal nOffset As Long, _
                      ByVal nTargetAddr As Long)
  On Error GoTo zPatchRel_Error

  Call RtlMoveMemory(ByVal nAddr + nOffset, nTargetAddr - nAddr - nOffset - 4, 4)
  Exit Sub

zPatchRel_Error:
End Sub

'Patch the machine code buffer at the indicated offset with the passed value
Private Sub zPatchVal(ByVal nAddr As Long, _
                      ByVal nOffset As Long, _
                      ByVal nValue As Long)
  On Error GoTo zPatchVal_Error

  Call RtlMoveMemory(ByVal nAddr + nOffset, nValue, 4)
  Exit Sub

zPatchVal_Error:
End Sub

'Worker function for Subclass_InIDE
Private Function zSetTrue(ByRef bValue As Boolean) As Boolean
  On Error GoTo zSetTrue_Error

  zSetTrue = True
  bValue = True
  Exit Function

zSetTrue_Error:
End Function

'*************************************************************
'
'added by teee_eeee: unneded pMask Picture Box
'
'*************************************************************

Private Sub TransBlt(ByVal DstDC As Long, ByVal DstX As Long, ByVal DstY As Long, ByVal DstW As Long, ByVal DstH As Long, ByVal SrcPic As StdPicture, Optional ByVal TransColor As Long = -1, Optional ByVal BrushColor As Long = -1, Optional ByVal MonoMask As Boolean = False, Optional ByVal isGreyscale As Boolean = False, Optional ByVal XPBlend As Boolean = False)

   If DstW = 0 Or DstH = 0 Then Exit Sub

   Dim B        As Long
   Dim H        As Long
   Dim F        As Long
   Dim I        As Long
   Dim newW     As Long
   Dim TmpDC    As Long
   Dim TmpBmp   As Long
   Dim TmpObj   As Long
   Dim Sr2DC    As Long
   Dim Sr2Bmp   As Long
   Dim Sr2Obj   As Long
   Dim Data1()  As RGBTRIPLE
   Dim Data2()  As RGBTRIPLE
   Dim Info     As BITMAPINFO
   Dim BrushRGB As RGBTRIPLE
   Dim gCol     As Long

   Dim SrcDC    As Long
   Dim tObj     As Long
   Dim ttt      As Long

   SrcDC = CreateCompatibleDC(hDC)

   If DstW < 0 Then DstW = UserControl.ScaleX(SrcPic.Width, 8, UserControl.ScaleMode)
   If DstH < 0 Then DstH = UserControl.ScaleY(SrcPic.Height, 8, UserControl.ScaleMode)

   If SrcPic.Type = 1 Then
      tObj = SelectObject(SrcDC, SrcPic)
   Else
      Dim hBrush As Long
      tObj = SelectObject(SrcDC, CreateCompatibleBitmap(DstDC, DstW, DstH))
      hBrush = CreateSolidBrush(MaskColor)
      DrawIconEx SrcDC, 0, 0, SrcPic.Handle, 0, 0, 0, hBrush, &H1 Or &H2
      DeleteObject hBrush
   End If

   TmpDC = CreateCompatibleDC(SrcDC)
   Sr2DC = CreateCompatibleDC(SrcDC)
   TmpBmp = CreateCompatibleBitmap(DstDC, DstW, DstH)
   Sr2Bmp = CreateCompatibleBitmap(DstDC, DstW, DstH)
   TmpObj = SelectObject(TmpDC, TmpBmp)
   Sr2Obj = SelectObject(Sr2DC, Sr2Bmp)
   
   ReDim Data1(DstW * DstH * 3 - 1)
   ReDim Data2(UBound(Data1))
   
   With Info.bmiHeader
      .biSize = Len(Info.bmiHeader)
      .biWidth = DstW
      .biHeight = DstH
      .biPlanes = 1
      .biBitCount = 24
   End With

   BitBlt TmpDC, 0, 0, DstW, DstH, DstDC, DstX, DstY, vbSrcCopy
   BitBlt Sr2DC, 0, 0, DstW, DstH, SrcDC, 0, 0, vbSrcCopy
   GetDIBits TmpDC, TmpBmp, 0, DstH, Data1(0), Info, 0
   GetDIBits Sr2DC, Sr2Bmp, 0, DstH, Data2(0), Info, 0

   If BrushColor > 0 Then
      BrushRGB.rgbBlue = (BrushColor \ &H10000) Mod &H100
      BrushRGB.rgbGreen = (BrushColor \ &H100) Mod &H100
      BrushRGB.rgbRed = BrushColor And &HFF
   End If

   If Not m_UseMaskColor Then TransColor = -1

   newW = DstW - 1

   For H = 0 To DstH - 1
      F = H * DstW
      For B = 0 To newW
         I = F + B
         If GetNearestColor(hDC, CLng(Data2(I).rgbRed) + 256& * Data2(I).rgbGreen + 65536 * Data2(I).rgbBlue) <> TransColor Then
            With Data1(I)
               If BrushColor > -1 Then
                  If MonoMask Then
                     If (CLng(Data2(I).rgbRed) + Data2(I).rgbGreen + Data2(I).rgbBlue) <= 384 Then Data1(I) = BrushRGB
                  Else
                     Data1(I) = BrushRGB
                  End If
               Else
                  If isGreyscale Then
                     gCol = CLng(Data2(I).rgbRed * 0.3) + Data2(I).rgbGreen * 0.59 + Data2(I).rgbBlue * 0.11
                     .rgbRed = gCol: .rgbGreen = gCol: .rgbBlue = gCol
                  Else
                     If XPBlend Then
                        .rgbRed = (CLng(.rgbRed) + Data2(I).rgbRed * 2) \ 3
                        .rgbGreen = (CLng(.rgbGreen) + Data2(I).rgbGreen * 2) \ 3
                        .rgbBlue = (CLng(.rgbBlue) + Data2(I).rgbBlue * 2) \ 3
                     Else
                        Data1(I) = Data2(I)
                     End If
                  End If
               End If
            End With
            
         End If
      
      Next B
   
   Next H

   SetDIBitsToDevice DstDC, DstX, DstY, DstW, DstH, 0, 0, 0, DstH, Data1(0), Info, 0

   Erase Data1, Data2
   DeleteObject SelectObject(TmpDC, TmpObj)
   DeleteObject SelectObject(Sr2DC, Sr2Obj)
   If SrcPic.Type = 3 Then DeleteObject SelectObject(SrcDC, tObj)
   DeleteDC TmpDC: DeleteDC Sr2DC
   DeleteObject tObj: DeleteDC SrcDC

End Sub

'*************************************************************
'
'added by Dennis (dvrdsr) function excerpted vlad memdc class'
'
'*************************************************************
Public Function PaintIconGrayscale(ByVal Dest_hDC As Long, _
                                   ByVal hIcon As Long, _
                                   Optional ByVal Dest_X As Long, _
                                   Optional ByVal Dest_Y As Long, _
                                   Optional ByVal Dest_Height As Long, _
                                   Optional ByVal Dest_Width As Long) As Boolean
  On Error GoTo PaintIconGrayscale_Error

  Dim hBMP_Mask  As Long
  Dim hBMP_Image As Long
  Dim hBMP_Prev  As Long
  Dim hIcon_Temp As Long
  Dim hDC_Temp   As Long

  ' Make sure parameters passed are valid
  If Dest_hDC = 0 Or hIcon = 0 Then Exit Function

  ' Extract the bitmaps from the icon
  If pvGetIconBitmaps(hIcon, hBMP_Mask, hBMP_Image) = False Then Exit Function
  ' Create a memory DC to work with
  hDC_Temp = CreateCompatibleDC(0)

  If hDC_Temp = 0 Then GoTo CleanUp

  ' Make the image bitmap gradient
  If pvRenderBitmapGrayscale(hDC_Temp, hBMP_Image, 0, 0) = False Then GoTo CleanUp
  ' Extract the gradient bitmap out of the DC
  SelectObject hDC_Temp, hBMP_Prev
  ' Take the newly gradient bitmap and make a gradient icon from it
  hIcon_Temp = pvCreateIconFromBMP(hBMP_Mask, hBMP_Image)

  If hIcon_Temp = 0 Then GoTo CleanUp

  ' Draw the newly created gradient icon onto the specified DC
  If DrawIconEx(Dest_hDC, Dest_X, Dest_Y, hIcon_Temp, Dest_Width, Dest_Height, 0, 0, &H3) <> 0 Then
    PaintIconGrayscale = True
  End If

CleanUp:
  DestroyIcon hIcon_Temp: hIcon_Temp = 0
  DeleteDC hDC_Temp: hDC_Temp = 0
  DeleteObject hBMP_Mask: hBMP_Mask = 0
  DeleteObject hBMP_Image: hBMP_Image = 0
  Exit Function

PaintIconGrayscale_Error:
End Function

Private Function pvGetIconBitmaps(ByVal hIcon As Long, _
                                  ByRef Return_hBmpMask As Long, _
                                  ByRef Return_hBmpImage As Long) As Boolean
  On Error GoTo pvGetIconBitmaps_Error

  Dim TempICONINFO As ICONINFO

  If GetIconInfo(hIcon, TempICONINFO) = 0 Then Exit Function
  Return_hBmpMask = TempICONINFO.hbmMask
  Return_hBmpImage = TempICONINFO.hbmColor
  pvGetIconBitmaps = True
  Exit Function

pvGetIconBitmaps_Error:
End Function