|
-
Nov 14th, 2002, 11:22 PM
#1
Thread Starter
Good Ol' Platypus
 Graphics Module
Here's a general-purpose graphics module with many APIs that 'sister' existing ones (such as AlphaBlt and TileBlt). Part 1, Declarations:
VB Code:
Option Explicit
Public Type mLong
L As Long
End Type
Public Type mRGB
R As Byte
G As Byte
B As Byte
A As Byte
End Type
Public Enum TEXTDRAWPARAM
TDP_LEFT = 0
TDP_RIGHT = 1
TDP_HCENTRE = 2
TDP_TOP = 4
TDP_BOTTOM = 8
TDP_VCENTRE = 16
End Enum
Public Const FW_DONTCARE = 0
Public Const FW_THIN = 100
Public Const FW_EXTRALIGHT = 200
Public Const FW_LIGHT = 300
Public Const FW_NORMAL = 400
Public Const FW_MEDIUM = 500
Public Const FW_SEMIBOLD = 600
Public Const FW_BOLD = 700
Public Const FW_EXTRABOLD = 800
Public Const FW_HEAVY = 900
Public Const FW_BLACK = FW_HEAVY
Public Const FW_DEMIBOLD = FW_SEMIBOLD
Public Const FW_REGULAR = FW_NORMAL
Public Const FW_ULTRABOLD = FW_EXTRABOLD
Public Const FW_ULTRALIGHT = FW_EXTRALIGHT
Public Const ANSI_CHARSET = 0
Public Const DEFAULT_CHARSET = 1
Public Const SYMBOL_CHARSET = 2
Public Const SHIFTJIS_CHARSET = 128
Public Const HANGEUL_CHARSET = 129
Public Const CHINESEBIG5_CHARSET = 136
Public Const OEM_CHARSET = 255
Public Const OUT_CHARACTER_PRECIS = 2
Public Const OUT_DEFAULT_PRECIS = 0
Public Const OUT_DEVICE_PRECIS = 5
Public Const CLIP_DEFAULT_PRECIS = 0
Public Const CLIP_CHARACTER_PRECIS = 1
Public Const CLIP_STROKE_PRECIS = 2
Public Const DEFAULT_QUALITY = 0
Public Const DRAFT_QUALITY = 1
Public Const PROOF_QUALITY = 2
Public Const DEFAULT_PITCH = 0
Public Const FIXED_PITCH = 1
Public Const VARIABLE_PITCH = 2
Public Const OPAQUE = 2
Public Const TRANSPARENT = 1
Public Const LOGPIXELSY = 90
Public Const OBJ_BITMAP = 7
Public Const DT_RIGHT = &H2
Public Const BI_RGB = 0&
Public Const DIB_RGB_COLORS = 0
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public 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
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public 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 GetCurrentObject Lib "gdi32" (ByVal hdc As Long, ByVal uObjectType As Long) As Long
Public Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor 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 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 ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" (ByVal lpszFile As String, ByVal nIconIndex As Long, phiconLarge As Long, phiconSmall As Long, ByVal nIcons As Long) As Long
Public Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Public Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Public Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZE) As Long
Public Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Public Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex 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 Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
Public Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Public Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Public Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Public Const DI_MASK = &H1
Public Const DI_IMAGE = &H2
Public Const DI_NORMAL = DI_MASK Or DI_IMAGE
Public Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Public Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Public Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Type BITMAPINFOHEADER '40 bytes
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Public Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As mRGB
End Type
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type SIZE
cx As Long
cy As Long
End Type
All contents of the above post that aren't somebody elses are mine, not the property of some media corporation. 
(Just a heads-up)
-
Nov 14th, 2002, 11:23 PM
#2
Thread Starter
Good Ol' Platypus
Part II, Code Part One:
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
All contents of the above post that aren't somebody elses are mine, not the property of some media corporation.
(Just a heads-up)
-
Nov 14th, 2002, 11:23 PM
#3
Thread Starter
Good Ol' Platypus
Part III, Code Part II:
VB Code:
Public Function SmoothIconBlt(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
Dim hResult As Long
Dim hImgDC As Long
Dim hMaskDC As Long
Dim hTempDC As Long
hImgDC = CreateMyDC(16, 16)
hMaskDC = CreateMyDC(16, 16)
hTempDC = CreateMyDC(16, 16)
Call ExtractIconEx(hExeSrc, hIndex, hLgIco, hSmIco, 1)
If hSmallIcon Then
hResult = DrawIconEx(hMaskDC, 0, 0, hSmIco, 16, 16, 0, 0, DI_MASK)
hResult = DrawIconEx(hImgDC, 0, 0, hSmIco, 16, 16, 0, 0, DI_IMAGE)
SmoothMaskFast hTempDC, hMaskDC, 0, 0, 16, 16, smoothval
AlphaBltFast hDestDC, X, Y, 16, 16, hImgDC, hMaskDC, 0, 0
Else
hResult = DrawIconEx(hMaskDC, 0, 0, hLgIco, 32, 32, 0, 0, DI_MASK)
hResult = DrawIconEx(hImgDC, 0, 0, hLgIco, 32, 32, 0, 0, DI_IMAGE)
SmoothMaskFast hTempDC, hMaskDC, 0, 0, 32, 32, smoothval * 2
AlphaBltFast hDestDC, X, Y, 32, 32, hImgDC, hMaskDC, 0, 0
End If
DestroyIcon hSmIco: DestroyIcon hLgIco
ReleaseDC frmMain.hwnd, hImgDC
ReleaseDC frmMain.hwnd, hMaskDC
ReleaseDC frmMain.hwnd, hTempDC
End Function
Public Function SmoothMaskFast(ByVal hDestDC As Long, ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal hWidth As Long, ByVal hHeight As Long, ByVal hSmoothWeight As Long)
Dim hInverse As Long
Dim I As Long, J As Long
Dim Base As Long
Dim Plus As Long
Dim Dot As Long
Dim Q As Long
Dim nDot As Long
Dim nPlus As Long
Dim xBitmap As Long
Dim xBMP As BITMAP
Dim xPic() As mRGB
Dim xMem As BITMAPINFO
xBitmap = GetCurrentObject(hDestDC, OBJ_BITMAP)
GetObjectAPI xBitmap, Len(xBMP), xBMP
With xMem.bmiHeader
.biBitCount = 32
.biCompression = BI_RGB
.biPlanes = 1
.biSize = Len(xMem.bmiHeader)
.biWidth = xBMP.bmWidth
.biHeight = xBMP.bmHeight
ReDim Preserve xPic(0 To (.biWidth * .biHeight) - 1) As mRGB
End With
GetDIBits hDestDC, xBitmap, 0, xBMP.bmHeight, xPic(0), xMem, DIB_RGB_COLORS
hInverse = 100 - (6 * hSmoothWeight)
'.+. This requires explaining. # will recieve hInverse rating, + will
'+#+ recieve hSmoothWeight rating, and . will recieve half of hSmoothWieght
'.+. as its rating. Thus 4 * hSmoothWeight + (4 * 0.5) * hSmoothWeight, or 6 * hSmoothweight
For J = Y To Y + (hHeight - 1)
For I = X To X + (hWidth - 1)
Dot = 0
Q = 0
Base = 0
Plus = 0
nPlus = 0
nDot = 0
Q = xPic(Morph2D(I, hHeight - J, hWidth)).R
Base = Mono(Q)
If Base = 0 Then
If I - 1 >= X Then
Plus = Plus + MonoA(xPic(Morph2D(I - 1, hHeight - J, hWidth)).R)
nPlus = nPlus + 1
If J - 1 >= Y Then
Dot = Dot + MonoA(xPic(Morph2D(I - 1, hHeight - (J - 1), hWidth)).R)
nDot = nDot + 1
End If
If J + 1 <= Y + (hHeight - 1) Then
Dot = Dot + MonoA(xPic(Morph2D(I - 1, hHeight - (J + 1), hWidth)).R)
nDot = nDot + 1
End If
End If
If I + 1 <= X + (hWidth - 1) Then
Plus = Plus + MonoA(xPic(Morph2D(I + 1, hHeight - J, hWidth)).R)
nPlus = nPlus + 1
If J - 1 >= Y Then
Dot = Dot + MonoA(xPic(Morph2D(I + 1, hHeight - (J - 1), hWidth)).R)
nDot = nDot + 1
End If
If J + 1 <= Y + (hHeight - 1) Then
Dot = Dot + MonoA(xPic(Morph2D(I + 1, hHeight - (J + 1), hWidth)).R)
nDot = nDot + 1
End If
End If
If J + 1 <= Y + (hHeight - 1) Then
Plus = Plus + MonoA(xPic(Morph2D(I, hHeight - (J + 1), hWidth)).R)
nPlus = nPlus + 1
End If
If J - 1 >= Y Then
Plus = Plus + MonoA(xPic(Morph2D(I, hHeight - (J - 1), hWidth)).R)
nPlus = nPlus + 1
End If
Plus = Plus / nPlus
Dot = Dot / nDot
Base = ((hInverse / 100) * Base) + ((hSmoothWeight * 4 / 100) * Plus) + ((hSmoothWeight * 2 / 100) * Dot)
With xPic(Morph2D(I, hHeight - J, hWidth))
.R = Base
.G = Base
.B = Base
End With
End If
Next I
Next J
SetDIBits hDestDC, xBitmap, 0, xBMP.bmHeight, xPic(0), xMem, DIB_RGB_COLORS
End Function
Public Function SmoothMask(ByVal hDestDC As Long, ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal hWidth As Long, ByVal hHeight As Long, ByVal hSmoothWeight As Long)
Dim hInverse As Long
Dim I As Long, J As Long
Dim Base As Long
Dim Plus As Long
Dim Dot As Long
Dim Q As Long
Dim nDot As Long
Dim nPlus As Long
hInverse = 100 - (6 * hSmoothWeight)
'.+. This requires explaining. # will recieve hInverse rating, + will
'+#+ recieve hSmoothWeight rating, and . will recieve half of hSmoothWieght
'.+. as its rating. Thus 4 * hSmoothWeight + (4 * 0.5) * hSmoothWeight, or 6 * hSmoothweight
For J = Y To Y + (hHeight - 1)
For I = X To X + (hWidth - 1)
Dot = 0
Q = 0
Base = 0
Plus = 0
nPlus = 0
nDot = 0
Q = GetPixel(hDestDC, I, J)
Base = Mono(Q)
If Base = 0 Then
Q = GetPixel(hdc, I - 1, J)
If Q <> -1 Then
Plus = Plus + Mono(Q)
nPlus = nPlus + 1
End If
Q = GetPixel(hdc, I + 1, J)
If Q <> -1 Then
Plus = Plus + Mono(Q)
nPlus = nPlus + 1
End If
Q = GetPixel(hdc, I, J - 1)
If Q <> -1 Then
Plus = Plus + Mono(Q)
nPlus = nPlus + 1
End If
Q = GetPixel(hdc, I, J + 1)
If Q <> -1 Then
Plus = Plus + Mono(Q)
nPlus = nPlus + 1
End If
Plus = Plus / nPlus
Q = GetPixel(hdc, I - 1, J - 1)
If Q <> -1 Then
Dot = Dot + Mono(Q)
nDot = nDot + 1
End If
Q = GetPixel(hdc, I + 1, J - 1)
If Q <> -1 Then
Dot = Dot + Mono(Q)
nDot = nDot + 1
End If
Q = GetPixel(hdc, I - 1, J + 1)
If Q <> -1 Then
Dot = Dot + Mono(Q)
nDot = nDot + 1
End If
Q = GetPixel(hdc, I + 1, J + 1)
If Q <> -1 Then
Dot = Dot + Mono(Q)
nDot = nDot + 1
End If
Dot = Dot / nDot
Base = ((hInverse / 100) * Base) + ((hSmoothWeight * 4 / 100) * Plus) + ((hSmoothWeight * 2 / 100) * Dot)
SetPixelV hDestDC, I, J, RGB(Base, Base, Base)
End If
Next I
Next J
End Function
Public Function Mono(Valu As Long) As Long
If Valu = 0 Then Mono = 0 Else Mono = 255
End Function
Public Function MonoA(Valu As Byte) As Long
If Valu = 0 Then MonoA = 0 Else MonoA = 255
End Function
Public Function CreateMyDC(Width As Long, Height As Long, Optional hCompatDC As Long) As Long
Dim iCompatDC As Long
Dim iDC As Long
If IsMissing(hCompatDC) Then
iCompatDC = GetDC(GetDesktopWindow)
Else
iCompatDC = hCompatDC
End If
iDC = CreateCompatibleDC(iCompatDC)
DeleteObject SelectObject(iDC, CreateCompatibleBitmap(iCompatDC, Width, Height))
CreateMyDC = iDC
End Function
Public Function DestroyDC(lngDC As Long) As Boolean
ReleaseDC frmMain.hwnd, lngDC
End Function
Public Function Morph2D(X As Long, Y As Long, NumRow As Long) As Long
Morph2D = (Y - 1) * NumRow + X
End Function
All contents of the above post that aren't somebody elses are mine, not the property of some media corporation.
(Just a heads-up)
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|
Reply With Quote