• Home
 · 
• Graphics
 · 
• Standard bitmap class. Enables you to have an extra graphics DC to play around with. Includes all s

Standard bitmap class. Enables you to have an extra graphics DC to play around with. Includes all s

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



Rate Standard bitmap class. Enables you to have an extra graphics DC to play around with. Includes all s

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

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