VB Code:
Public Function TextBlt(ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal Text As String, ByVal TextColour As Long, ByVal TextPoint As Integer, ByVal TextFace As String, ByVal dwFlags As TEXTDRAWPARAM)
Dim tRect As RECT
Dim Q As SIZE
GetTextExtentPoint32 hDestDC, Text, Len(Text), Q
With tRect
If dwFlags And TDP_RIGHT Then
.Left = X - (Q.cx + 5)
.Right = X
ElseIf dwFlags And TDP_HCENTRE Then
.Left = X - (Q.cx / 2)
.Right = X + (Q.cx / 2)
Else
.Left = X
.Right = X + (Q.cx - 1)
End If
If dwFlags And TDP_BOTTOM Then
.Top = Y - (Q.cy + 5)
.Bottom = Y
ElseIf dwFlags And TDP_VCENTRE Then
.Top = Y - (Q.cy / 2)
.Bottom = Y + (Q.cy / 2)
Else
.Top = Y
.Bottom = Y + (Q.cy - 1)
End If
End With
SelectObject hDestDC, CreateMyFont(TextPoint, TextFace)
SetTextColor hDestDC, TextColour
DrawText hDestDC, Text, Len(Text), tRect, 0
End Function
Public Function CreateMyFont(nSize As Integer, sFace As String) As Long 'FROM ALL-API.NET, MODIFIED
'Create a specified font
CreateMyFont = CreateFont(-MulDiv(nSize, GetDeviceCaps(GetDC(0), LOGPIXELSY), 72), 0, 0, 0, FW_NORMAL, False, False, False, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, sFace)
End Function
Public Function CropTextBlt(ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Text As String, ByVal TextColour As Long, ByVal TextPoint As Integer, ByVal TextFace As String, ByVal dwFlags As TEXTDRAWPARAM)
Dim CropText As String
Dim Q As SIZE
SelectObject hDestDC, CreateMyFont(TextPoint, TextFace)
GetTextExtentPoint32 hDestDC, Text, Len(Text), Q
CropText = Text
Do While Q.cx > Width
Q.cx = 0: Q.cy = 0
CropText = Left$(CropText, Len(CropText) - 1)
GetTextExtentPoint32 hDestDC, CropText, Len(CropText), Q
Loop
If CropText <> Text Then
If Len(CropText) > 3 Then
CropText = Left$(CropText, Len(CropText) - 3) & "..."
Else
If Len(CropText) = 3 Then CropText = "..."
If Len(CropText) = 2 Then CropText = ".."
If Len(CropText) = 1 Then CropText = "."
End If
End If
TextBlt hDestDC, X, Y, CropText, TextColour, TextPoint, TextFace, dwFlags
End Function
Public Function AlphaBltFast(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 hAlphaDC As Long, ByVal xSrc As Long, ByVal ySrc As Long)
Dim I As Long
Dim J As Long
Dim TempR As Long
Dim TempG As Long
Dim TempB As Long
Dim AlphaVal As mRGB
Dim SrcVal As mRGB
Dim DestVal As mRGB
Dim dBitmap As Long
Dim dBMP As BITMAP
Dim dPic() As mRGB
Dim dMem As BITMAPINFO
Dim sBitmap As Long
Dim sBMP As BITMAP
Dim sPic() As mRGB
Dim sMem As BITMAPINFO
Dim aBitmap As Long
Dim aBMP As BITMAP
Dim aPic() As mRGB
Dim aMem As BITMAPINFO
dBitmap = GetCurrentObject(hDestDC, OBJ_BITMAP)
sBitmap = GetCurrentObject(hSrcDC, OBJ_BITMAP)
aBitmap = GetCurrentObject(hAlphaDC, OBJ_BITMAP)
GetObjectAPI dBitmap, Len(dBMP), dBMP
GetObjectAPI sBitmap, Len(sBMP), sBMP
GetObjectAPI aBitmap, Len(aBMP), aBMP
With dMem.bmiHeader
.biBitCount = 32
.biCompression = BI_RGB
.biPlanes = 1
.biSize = Len(dMem.bmiHeader)
.biWidth = dBMP.bmWidth
.biHeight = dBMP.bmHeight
ReDim Preserve dPic(0 To (.biWidth * .biHeight) - 1) As mRGB
End With
GetDIBits hDestDC, dBitmap, 0, dBMP.bmHeight, dPic(0), dMem, DIB_RGB_COLORS
With sMem.bmiHeader
.biBitCount = 32
.biCompression = BI_RGB
.biPlanes = 1
.biSize = Len(sMem.bmiHeader)
.biWidth = sBMP.bmWidth
.biHeight = sBMP.bmHeight
ReDim Preserve sPic(0 To (.biWidth * .biHeight) - 1) As mRGB
End With
GetDIBits hSrcDC, sBitmap, 0, sBMP.bmHeight, sPic(0), sMem, DIB_RGB_COLORS
With aMem.bmiHeader
.biBitCount = 32
.biCompression = BI_RGB
.biPlanes = 1
.biSize = Len(aMem.bmiHeader)
.biWidth = aBMP.bmWidth
.biHeight = aBMP.bmHeight
ReDim Preserve aPic(0 To (.biWidth * .biHeight) - 1) As mRGB
End With
GetDIBits hAlphaDC, aBitmap, 0, aBMP.bmHeight, aPic(0), aMem, DIB_RGB_COLORS
For J = Y To Y + (nHeight - 1)
For I = X To X + (nWidth - 1)
DestVal = dPic(Morph2D(I, dBMP.bmHeight - J, dBMP.bmWidth)) 'dColour.L = GetPixel(hDestDC, I, J)
SrcVal = sPic(Morph2D(I - X + xSrc, sBMP.bmHeight - (J - Y + ySrc), sBMP.bmWidth)) 'sColour.L = GetPixel(hSrcDC, I - x + xSrc, J - y + ySrc)
AlphaVal = aPic(Morph2D(I - X + xSrc, aBMP.bmHeight - (J - Y + ySrc), aBMP.bmWidth)) 'aColour.L = GetPixel(hAlphaDC, I - x + xSrc, J - y + ySrc)
AlphaVal.R = 255 - AlphaVal.R
AlphaVal.G = 255 - AlphaVal.G
AlphaVal.B = 255 - AlphaVal.B
TempR = (AlphaVal.R * CLng(SrcVal.R + 256 - DestVal.R)) / 256 + DestVal.R - AlphaVal.R
TempG = (AlphaVal.G * CLng(SrcVal.G + 256 - DestVal.G)) / 256 + DestVal.G - AlphaVal.G
TempB = (AlphaVal.B * CLng(SrcVal.B + 256 - DestVal.B)) / 256 + DestVal.B - AlphaVal.B
With dPic(Morph2D(I, dBMP.bmHeight - J, dBMP.bmWidth))
.R = TempR
.G = TempG
.B = TempB
End With
Next I
Next J
SetDIBits hDestDC, dBitmap, 0, dBMP.bmHeight, dPic(0), dMem, DIB_RGB_COLORS
End Function
Public Function AlphaBlt(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 hAlphaDC As Long, ByVal xSrc As Long, ByVal ySrc As Long)
Dim I As Long
Dim J As Long
Dim dColour As mLong
Dim dRGB As mRGB
Dim sColour As mLong
Dim sRGB As mRGB
Dim aColour As mLong
Dim aRGB As mRGB
Dim TempR As Long
Dim TempG As Long
Dim TempB As Long
For J = Y To Y + (nHeight - 1)
For I = X To X + (nWidth - 1)
dColour.L = GetPixel(hDestDC, I, J)
sColour.L = GetPixel(hSrcDC, I - X + xSrc, J - Y + ySrc)
aColour.L = GetPixel(hAlphaDC, I - X + xSrc, J - Y + ySrc)
LSet dRGB = dColour
LSet sRGB = sColour
LSet aRGB = aColour
aRGB.R = 255 - aRGB.R
aRGB.G = 255 - aRGB.G
aRGB.B = 255 - aRGB.B
TempR = (aRGB.R * CLng(sRGB.R + 256 - dRGB.R)) / 256 + dRGB.R - aRGB.R
TempG = (aRGB.G * CLng(sRGB.G + 256 - dRGB.G)) / 256 + dRGB.G - aRGB.G
TempB = (aRGB.B * CLng(sRGB.B + 256 - dRGB.B)) / 256 + dRGB.B - aRGB.B
SetPixelV hDestDC, I, J, RGB(TempR, TempG, TempB)
Next I
Next J
End Function
Public Function TileBlt(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 srcWidth As Long, ByVal srcHeight As Long, ByVal dwRop As Long)
Dim I As Long
Dim J As Long
Dim ICut As Long
Dim JCut As Long
For J = Y To Y + (nHeight - 1) Step srcHeight
If J + srcHeight > Y + (nHeight - 1) Then
JCut = (Y + nHeight) - J
Else
JCut = srcHeight
End If
For I = X To X + (nWidth - 1) Step srcWidth
If I + srcWidth > X + (nWidth - 1) Then
ICut = (X + nWidth) - I
Else
ICut = srcWidth
End If
BitBlt hDestDC, I, J, ICut, JCut, hSrcDC, xSrc, ySrc, dwRop
Next I
Next J
End Function
Public Function IconBlt(ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal hExeSrc As String, ByVal hIndex As Long, ByVal hSmallIcon As Boolean) As Long
Dim hSmIco As Long
Dim hLgIco As Long
Call ExtractIconEx(hExeSrc, hIndex, hLgIco, hSmIco, 1)
If hSmallIcon Then
IconBlt = DrawIconEx(hDestDC, X, Y, hSmIco, 16, 16, 0, 0, DI_NORMAL)
Else
IconBlt = DrawIconEx(hDestDC, X, Y, hLgIco, 32, 32, 0, 0, DI_NORMAL)
End If
DestroyIcon hSmIco: DestroyIcon hLgIco
End Function