Vet inte om denna fungerar som du vill.
Det är en class module som jag hittade.
Hur som helst annars om denna inte funkar leta info om Bitblt
Option Explicit
'Device context functions
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
'Gdi object functions
Private Declare Function GetObj Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'Bitmap functions
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function CreateBitmapIndirect Lib "gdi32" (ByVal lpbm 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 CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
'Window functions
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
'Color functions
Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
'Text functions
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
'Rendering functions
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
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
'The needed variables
Private MainDC As Long
Private hMainPrevBitmap As Long
Public hMainBitmap As Long
Private MainCreated As Boolean
Private MaskDC As Long
Private hMaskPrevBitmap As Long
Public hMaskBitmap As Long
Private MaskCreated As Boolean
Public Width As Long
Public Height As Long
Private Enum BitBltConstants
SRCCOPY = &HCC0020'/* dest = source */
SRCPAINT = &HEE0086'/* dest = source OR dest*/
SRCAND = &H8800C6'/* dest = source AND dest*/
SRCINVERT = &H660046'/* dest = source XOR dest*/
SRCERASE = &H440328'/* dest = source AND (NOT dest ) */
NOTSRCCOPY = &H330008'/* dest = (NOT source)*/
NOTSRCERASE = &H1100A6'/* dest = (NOT src) AND (NOT dest) */
MERGECOPY = &HC000CA'/* dest = (source AND pattern) */
MERGEPAINT = &HBB0226'/* dest = (NOT source) OR dest */
PATCOPY = &HF00021'/* dest = pattern */
PATPAINT = &HFB0A09'/* dest = DPSnoo */
PATINVERT = &H5A0049'/* dest = pattern XOR dest*/
DSTINVERT = &H550009'/* dest = (NOT dest)*/
BLACKNESS = &H42'/* dest = BLACK */
WHITENESS = &HFF0062'/* dest = WHITE */
End Enum
Private Sub FreeMainBitmap()
If MainCreated Then 'Only delete our bitmap if we created it first
SelectObject MainDC, hMainPrevBitmap
DeleteObject hMainBitmap
MainCreated = False
End If
End Sub
Private Sub FreeMaskBitmap()
If MaskCreated Then 'Only delete our bitmap if we created it first
SelectObject MaskDC, hMaskPrevBitmap
DeleteObject hMaskBitmap
MaskCreated = False
End If
End Sub
Private Sub NewBitmap(Width As Long, Height As Long, BitsPerPixel As Long)
FreeMainBitmap
hMainBitmap = CreateBitmap(Width, Height, 1, BitsPerPixel, ByVal 0&)
hMainPrevBitmap = SelectObject(MainDC, hMainBitmap)
MainCreated = True
End Sub
Private Sub CreateMaskBitmap(Width As Long, Height As Long)
FreeMaskBitmap
hMaskBitmap = CreateBitmap(Width, Height, 1, 1, ByVal 0&)
hMaskPrevBitmap = SelectObject(MaskDC, hMaskBitmap)
MaskCreated = True
End Sub
Public Sub LoadHdc(hSrcDC As Long, X As Long, Y As Long, nWidth As Long, nHeight As Long, TransparentColor As Long)
'Set Width and height to nWidth and nHei
' ght
Width = nWidth
Height = nHeight
'Create bitmaps
CreateMaskBitmap Width, Height 'Create a mask bitmap
NewCompatibleBitmap hSrcDC, Width, Height 'Create a main bitmap
'Make our mask
Dim OrigColor As Long
OrigColor = SetBkColor(hSrcDC, TransparentColor)
BitBlt MaskDC, 0, 0, Width, Height, hSrcDC, X, Y, SRCCOPY 'Create our mask
SetBkColor hSrcDC, OrigColor 'Restore the original color
If TransparentColor = vbBlack Then
BitBlt MainDC, 0, 0, Width, Height, hSrcDC, X, Y, SRCCOPY
Else
SetBkColor MainDC, vbWhite
SetTextColor MainDC, vbBlack
'Make the transparent part black so we c
' an use it in bitblt
BitBlt MainDC, 0, 0, Width, Height, hSrcDC, X, Y, BLACKNESS
BitBlt MainDC, 0, 0, Width, Height, hSrcDC, X, Y, SRCINVERT
BitBlt MainDC, 0, 0, Width, Height, MaskDC, X, Y, SRCAND
BitBlt MainDC, 0, 0, Width, Height, hSrcDC, X, Y, SRCINVERT
End If
End Sub
Public Sub LoadHdcFromPicture(Picture As StdPicture, TransparentColor As Long)
Dim OurhDC As Long
Dim hPrevBmp As Long
OurhDC = CreateCompatibleDC(GetDC(0))
With Picture
hPrevBmp = SelectObject(OurhDC, .Handle)
LoadHdc OurhDC, 0, 0, .Width, .Height, TransparentColor
End With
SelectObject OurhDC, hPrevBmp
DeleteDC OurhDC
End Sub
Private Sub NewCompatibleBitmap(CompatibleDC As Long, Width As Long, Height As Long)
FreeMainBitmap
hMainBitmap = CreateCompatibleBitmap(CompatibleDC, Width, Height)
hMainPrevBitmap = SelectObject(MainDC, hMainBitmap)
MainCreated = True
End Sub
Private Sub Class_Initialize()
MainDC = CreateCompatibleDC(GetDC(0))
MaskDC = CreateCompatibleDC(GetDC(0))
End Sub
Private Sub Class_Terminate()
FreeMainBitmap
FreeMaskBitmap
DeleteDC MainDC
DeleteDC MaskDC
End Sub
Sub StretchRender(hDestDC As Long, X As Long, Y As Long, nWidth As Long, nHeight As Long, _
XSrc As Long, YSrc As Long, Optional ByVal SrcWidth As Long, Optional ByVal SrcHeight As Long, Optional Transparent As Boolean = True)
If SrcWidth = 0 Then SrcWidth = Width
If SrcHeight = 0 Then SrcHeight = Height
If Transparent Then
Dim SaveBkColor As Long
Dim SaveTextColor As Long
SaveTextColor = SetTextColor(hDestDC, vbBlack)
SaveBkColor = SetBkColor(hDestDC, vbWhite) '//All the white in our bitmap has to be white
StretchBlt hDestDC, X, Y, nWidth, nHeight, MaskDC, XSrc, YSrc, SrcWidth, SrcHeight, SRCAND
StretchBlt hDestDC, X, Y, nWidth, nHeight, MainDC, XSrc, YSrc, SrcWidth, SrcHeight, SRCPAINT
SetBkColor hDestDC, SaveBkColor
SetTextColor hDestDC, SaveTextColor
Else
StretchBlt hDestDC, X, Y, nWidth, nHeight, MainDC, XSrc, YSrc, SrcWidth, SrcHeight, SRCCOPY
End If
End Sub
Sub Render(hDestDC As Long, X As Long, Y As Long, nWidth As Long, nHeight As Long, _
XSrc As Long, YSrc As Long, Optional Transparent As Boolean = True)
If Transparent Then
Dim SaveBkColor As Long
Dim SaveTextColor As Long
SaveTextColor = SetTextColor(hDestDC, vbBlack)
SaveBkColor = SetBkColor(hDestDC, vbWhite) '//All the white in our bitmap has to be white
BitBlt hDestDC, X, Y, nWidth, nHeight, MaskDC, XSrc, YSrc, SRCAND
BitBlt hDestDC, X, Y, nWidth, nHeight, MainDC, XSrc, YSrc, SRCPAINT
SetBkColor hDestDC, SaveBkColor
SetTextColor hDestDC, SaveTextColor
Else
BitBlt hDestDC, X, Y, nWidth, nHeight, MainDC, XSrc, YSrc, SRCCOPY
End If
End Sub
Sub EraseDraw(hDestDC As Long, X As Long, Y As Long, nWidth As Long, nHeight As Long, BackGroundDC As Long, Optional PixelPerfectCollisionDetection As Boolean = False)
If PixelPerfectCollisionDetection Then
Dim SaveBkColor As Long
Dim SaveTextColor As Long
SaveTextColor = SetTextColor(hDestDC, vbBlack)
SaveBkColor = SetBkColor(hDestDC, vbWhite) '//All the white in our bitmap has to be white
BitBlt hDestDC, X, Y, nWidth, nHeight, BackGroundDC, X, Y, SRCINVERT
BitBlt hDestDC, X, Y, nWidth, nHeight, MaskDC, 0, 0, SRCAND
BitBlt hDestDC, X, Y, nWidth, nHeight, BackGroundDC, X, Y, SRCINVERT
SetBkColor hDestDC, SaveBkColor
SetTextColor hDestDC, SaveTextColor
Else
BitBlt hDestDC, X, Y, nWidth, nHeight, BackGroundDC, X, Y, vbSrcCopy
End If
End Sub