by Victor M. Stelein (1 Submission)
Category: Graphics
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Fri 12th December 2003
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Standard bitmap class. Enables you to have an extra graphics DC to play around with. Includes all standard properties. IE: ForeColor,
API Declarations
Option Explicit
Public Type BitmapFileHeader
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Public Type RGBQuad
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Public Type BitmapInfoHeader
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 RGBQuad
End Type
Public Type LogBrush
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Public Type PointAPI
X As Long
Y As Long
End Type
Public Type Size
cX As Long
cY As Long
End Type
Public Declare Function CreateBitmap Lib "GDI32.DLL" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Public Declare Function CreateBrushIndirect Lib "GDI32.DLL" (lpLogBrush As LogBrush) As Long
Public Declare Function CreateCompatibleDC Lib "GDI32.DLL" (ByVal hDC As Long) As Long
Public Declare Function CreateFont Lib "GDI32.DLL" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Boolean, ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
Public Declare Function CreatePen Lib "GDI32.DLL" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Public Declare Function DeleteDC Lib "GDI32.DLL" (ByVal hDC As Long) As Long
Public Declare Function DeleteObject Lib "GDI32.DLL" (ByVal hObject As Long) As Long
Public Declare Function GetDeviceCaps Lib "GDI32.DLL" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Public Declare Function GetDIBits Lib "GDI32.DLL" (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 GetTextExtentPoint Lib "GDI32.DLL" Alias "GetTextExtentPointA" (ByVal hDC As Long, ByVal lpszString As String, ByVal cbString As Long, lpSize As Size) As Long
Public Declare Function Polygon Lib "GDI32.DLL" (ByVal hDC As Long, lpPoint As PointAPI, ByVal nCount As Long) As Long
Public Declare Function SelectObject Lib "GDI32.DLL" (ByVal hDC As Long, ByVal hObject As Long) As Long
Public Declare Function SetBkColor Lib "GDI32.DLL" (ByVal hDC As Long, ByVal crColor As Long) As Long
Public Declare Function SetBkMode Lib "GDI32.DLL" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Public Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BitmapInfo, ByVal wUsage As Long) As Long
Public Declare Function SetTextAlign Lib "GDI32.DLL" (ByVal hDC As Long, ByVal wFlags As Long) As Long
Public Declare Function SetTextColor Lib "GDI32.DLL" (ByVal hDC As Long, ByVal crColor As Long) As Long
Public Declare Function TextOut Lib "GDI32.DLL" 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 MulDiv Lib "Kernel32.DLL" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Public Declare Function GetDC Lib "User32.DLL" (ByVal hWnd As Long) As Long
Public Declare Function GetSysColor Lib "User32.DLL" (ByVal nIndex As Long) As Long
Public Function GetOLEColor(ByVal nColor As Long) As Long
Dim nString As String
Let nString = Hex(nColor)
If Left(nString, 1) = 8 And Len(nString) = 8 Then Let nColor = GetSysColor("&H" & Right(nString, 7))
Let GetOLEColor = nColor
End Function
VBcoders
Option Explicit
Public Enum tsDrawModes
dmSolid = 0
dmDash = 1
dmDot = 2
dmDashDot = 3
dmDashDotDot = 4
dmInvisible = 5
End Enum
Public Enum tsFillStyles
fsSolid = 0
fsHorizontal = 1
fsVertical = 2
fsNWSEDiagonal = 3
fsNESWDiagonal = 4
fsCross = 5
fsDCross = 6
fsTransparent = 7
End Enum
Public Enum tsTextAlignments
aLeft = 0
aTop = 0
aRight = 2
aBottom = 8
aHCenter = 6
aVCenter = 24
aCenter = aHCenter Or aVCenter
End Enum
Private v_FontTransparent As Boolean
Private v_DrawWidth As Byte
Private v_TextAngle As Integer
Private hBrush As Long
Private hFont As Long
Private hPen As Long
Private r_hDC As Long
Private r_hBitmap As Long
Private v_BackColor As Long
Private v_CurrentX As Long
Private v_CurrentY As Long
Private v_FillColor As Long
Private v_ForeColor As Long
Private v_Height As Long
Private v_Width As Long
Private v_DrawMode As tsDrawModes
Private v_FillStyle As tsFillStyles
Private v_TextAlign As tsTextAlignments
Private WithEvents v_Font As StdFont
Public Property Let FontTransparent(ByVal nValue As Boolean)
Let v_FontTransparent = nValue
Call SetBkMode(r_hDC, 2 + nValue)
End Property
Public Property Get FontTransparent() As Boolean
Let FontTransparent = v_FontTransparent
End Property
Public Property Let DrawWidth(ByVal nValue As Byte)
Let v_DrawWidth = nValue
Call RefreshPen
End Property
Public Property Get DrawWidth() As Byte
Let DrawWidth = v_DrawWidth
End Property
Public Property Let TextAngle(ByVal nValue As Integer)
Let v_TextAngle = nValue
Call RefreshFont
End Property
Public Property Get TextAngle() As Integer
Let TextAngle = v_TextAngle
End Property
Public Property Let BackColor(ByVal nValue As Long)
Let v_BackColor = nValue
Call SetBkColor(r_hDC, GetOLEColor(nValue))
End Property
Public Property Get BackColor() As Long
Let BackColor = v_BackColor
End Property
Public Property Let CurrentX(ByVal nValue As Long)
Let v_CurrentX = nValue
End Property
Public Property Get CurrentX() As Long
Let CurrentX = v_CurrentX
End Property
Public Property Let CurrentY(ByVal nValue As Long)
Let v_CurrentY = nValue
End Property
Public Property Get CurrentY() As Long
Let CurrentY = v_CurrentY
End Property
Public Property Let FillColor(ByVal nValue As Long)
Let v_FillColor = nValue
Call RefreshBrush
End Property
Public Property Get FillColor() As Long
Let FillColor = v_FillColor
End Property
Public Property Let ForeColor(ByVal nValue As Long)
Let v_ForeColor = nValue
Call RefreshPen
Call SetTextColor(r_hDC, GetOLEColor(nValue))
End Property
Public Property Get ForeColor() As Long
Let ForeColor = v_ForeColor
End Property
Public Property Get Handle() As Long
Let Handle = r_hBitmap
End Property
Public Property Get hDC() As Long
Let hDC = r_hDC
End Property
Public Property Let Height(ByVal nValue As Long)
If Not v_Height = nValue Then Call Resize(v_Width, nValue)
End Property
Public Property Get Height() As Long
Let Height = v_Height
End Property
Public Property Let Width(ByVal nValue As Long)
If Not v_Width = nValue Then Call Resize(nValue, v_Height)
End Property
Public Property Get Width() As Long
Let Width = v_Width
End Property
Public Property Let DrawMode(ByVal nValue As tsDrawModes)
Let v_DrawMode = nValue
Call RefreshPen
End Property
Public Property Get DrawMode() As tsDrawModes
Let DrawMode = v_DrawMode
End Property
Public Property Let FillStyle(ByVal nValue As tsFillStyles)
Let v_FillStyle = nValue
Call RefreshBrush
End Property
Public Property Get FillStyle() As tsFillStyles
Let FillStyle = v_FillStyle
End Property
Public Property Let TextAlign(ByVal nValue As tsTextAlignments)
Let v_TextAlign = nValue
Call SetTextAlign(r_hDC, nValue)
End Property
Public Property Get TextAlign() As tsTextAlignments
Let TextAlign = v_TextAlign
End Property
Public Property Set Font(nValue As StdFont)
Set v_Font = nValue
Call RefreshFont
End Property
Public Property Get Font() As StdFont
Set Font = v_Font
End Property
Public Function LoadImage(ByVal lpPath As String) As Long
On Error GoTo ErrExit
Dim tDIBits() As Byte
Dim nWidth As Long, nHeight As Long
Dim tDC As Long
Dim nPicture As StdPicture
Dim Bmi As BitmapInfo
Set nPicture = LoadPicture(lpPath)
Let nWidth = nPicture.Width / 26.46
Let nHeight = nPicture.Height / 26.46
ReDim tDIBits(nWidth * nHeight * 3 - 1) As Byte
With Bmi.bmiHeader
Let .biWidth = nWidth
Let .biHeight = nHeight
Let .biBitCount = 24
Let .biPlanes = 1
Let .biSize = 40
End With
Let tDC = CreateCompatibleDC(GetDC(0))
Call GetDIBits(tDC, nPicture.Handle, 0, nHeight, tDIBits(0), Bmi, 0)
Call Resize(nWidth, nHeight)
Call SetDIBitsToDevice(r_hDC, 0, 0, nWidth, nHeight, 0, 0, 0, nHeight, tDIBits(0), Bmi, 0)
Call DeleteDC(tDC)
ErrExit:
Let LoadImage = Err.Number
Call Err.Clear: Exit Function
End Function
Public Function SaveImage(ByVal lpPath As String) As Long
On Error GoTo ErrExit
Dim tDIBits() As Byte
Dim nFile As Integer
Dim BmpF As BitmapFileHeader
Dim Bmi As BitmapInfo
If Not Dir(lpPath) = "" Then Call Kill(lpPath)
Let nFile = FreeFile
Open lpPath For Binary Access Write As nFile
Let BmpF.bfType = 19778
Let BmpF.bfSize = 54 + v_Width * v_Height * 3
Let BmpF.bfOffBits = 54
With Bmi.bmiHeader
Let .biBitCount = 24
Let .biWidth = v_Width
Let .biHeight = v_Height
Let .biPlanes = 1
Let .biSize = 40
End With
Put nFile, 1, BmpF
Put nFile, 15, Bmi.bmiHeader
ReDim tDIBits(v_Width * v_Height * 3 - 1) As Byte
Call GetDIBits(r_hDC, r_hBitmap, 0, v_Height, tDIBits(0), Bmi, 0)
Put nFile, 55, tDIBits
Close nFile: Exit Function
ErrExit:
Let SaveImage = Err.Number
Call Err.Clear: Exit Function
End Function
Public Function TextHeight(ByVal lpStr As String) As Long
Dim nSize As Size
Call GetTextExtentPoint(r_hDC, lpStr, Len(lpStr), nSize)
Let TextHeight = nSize.cY
End Function
Public Function TextWidth(ByVal lpStr As String) As Long
Dim nSize As Size
Call GetTextExtentPoint(r_hDC, lpStr, Len(lpStr), nSize)
Let TextWidth = nSize.cX
End Function
Public Sub Clear()
Dim nBrush As LogBrush
Dim tPoint(3) As PointAPI
If Not hBrush = 0 Then Call DeleteObject(hBrush)
Let nBrush.lbStyle = 0
Let nBrush.lbColor = GetOLEColor(v_BackColor)
Let hBrush = CreateBrushIndirect(nBrush)
Call DeleteObject(SelectObject(hDC, hBrush))
If Not hPen = 0 Then Call DeleteObject(hPen)
Let hPen = CreatePen(0, 1, GetOLEColor(v_BackColor))
Call DeleteObject(SelectObject(r_hDC, hPen))
Let tPoint(0).X = 0: Let tPoint(0).Y = 0
Let tPoint(1).X = v_Width - 1: Let tPoint(1).Y = 0
Let tPoint(2).X = v_Width - 1: Let tPoint(2).Y = v_Height - 1
Let tPoint(3).X = 0: Let tPoint(3).Y = v_Height - 1
Call Polygon(r_hDC, tPoint(0), 4)
Call RefreshBrush
Call RefreshPen
End Sub
Public Sub PrintText(ByVal lpStr As String)
Call TextOut(r_hDC, v_CurrentX, v_CurrentY, lpStr, Len(lpStr))
End Sub
Public Sub Resize(ByVal nWidth As Long, ByVal nHeight As Long)
Dim BitmapInfo As BitmapInfo
If nWidth <= 0 Or nHeight <= 0 Then Exit Sub
Call DeleteObject(r_hBitmap)
Call DeleteDC(r_hDC)
Let r_hDC = CreateCompatibleDC(GetDC(0))
If r_hDC = 0 Then Exit Sub
Let r_hBitmap = CreateBitmap(nWidth, nHeight, 1, 24, ByVal 0&)
If r_hBitmap = 0 Then Call DeleteDC(r_hDC): Exit Sub
Call DeleteObject(SelectObject(r_hDC, r_hBitmap))
Let v_Width = nWidth: Let v_Height = nHeight
Call RefreshBrush
Call RefreshFont
Call RefreshPen
Call SetBkColor(r_hDC, GetOLEColor(v_BackColor))
Call SetBkMode(r_hDC, 2 + v_FontTransparent)
Call SetTextAlign(r_hDC, v_TextAlign)
Call Clear
End Sub
Private Sub RefreshBrush()
Dim nBrush As LogBrush
Select Case v_FillStyle
Case fsSolid
Let nBrush.lbStyle = 0
Case fsTransparent
Let nBrush.lbStyle = 1
Case Else
Let nBrush.lbStyle = 2
Let nBrush.lbHatch = v_FillStyle - 1
End Select
Let nBrush.lbColor = GetOLEColor(v_FillColor)
Let hBrush = CreateBrushIndirect(nBrush)
Call DeleteObject(SelectObject(hDC, hBrush))
End Sub
Private Sub RefreshFont()
Let hFont = CreateFont(-MulDiv(v_Font.Size, GetDeviceCaps(r_hDC, 90), 72), 0, v_TextAngle * 10, 0, 400 - 300 * v_Font.Bold, v_Font.Italic, v_Font.Underline, v_Font.Strikethrough, 1, 0, 0, 2, 0, v_Font.Name)
Call DeleteObject(SelectObject(r_hDC, hFont))
End Sub
Private Sub RefreshPen()
Let hPen = CreatePen(v_DrawMode, v_DrawWidth, GetOLEColor(v_ForeColor))
Call DeleteObject(SelectObject(r_hDC, hPen))
End Sub
Private Sub Class_Initialize()
Let r_hDC = CreateCompatibleDC(GetDC(0))
Let r_hBitmap = CreateBitmap(1, 1, 1, 24, ByVal 0&)
Let v_Width = 1: v_Height = 1
Set v_Font = New StdFont
With v_Font
.Size = 8
.Name = "MS Sans Serif"
End With
Let BackColor = &H80000005
Let DrawMode = dmSolid
Let DrawWidth = 1
Let FillStyle = fsSolid
Let FillColor = &H80000005
Let FontTransparent = True
Let ForeColor = &H80000012
Call Clear
End Sub
Private Sub Class_Terminate()
Call DeleteObject(r_hBitmap)
Call DeleteObject(hBrush)
Call DeleteObject(hFont)
Call DeleteObject(hPen)
Call DeleteDC(r_hDC)
End Sub
Private Sub v_Font_FontChanged(ByVal PropertyName As String)
Call RefreshFont
End Sub
No comments have been posted about Standard bitmap class. Enables you to have an extra graphics DC to play around with. Includes all s. Why not be the first to post a comment about Standard bitmap class. Enables you to have an extra graphics DC to play around with. Includes all s.