Option Compare Database
Option Explicit
'Copyright: Stephen Lebans - Lebans Holdings 1999 Ltd.
' Please feel free to use this code within your own
' projects whether they are private or commercial applications
' without obligation.
' This code may not be resold by itself or as part of a collection.
'
'Name: clsPictureBox
'
'Version: 1.6
'
'Purpose:
' To mimic the functionality of the VB PictureBox control.
' In particular the ability to draw at runtime.
'
'
'Author: Stephen Lebans
'Email: Stephen@lebans.com
'
'Web Site: www.lebans.com
'
'Date: April 09, 2001, 11:11:11 PM
'
'Credits: The intel JPEG library for the skeleton
' DIBSection Class.
' Michael X. Bond for pushing me to fix
' my earliest attempts via my ImageClass project.
' Also thanks to Michael for the random Circle function!
'
' I was looking for an example of converting
' Rod Stephens' 4 pixel linear interpolation resampling
' code to use a DIBSection instead of palettes.
' I came across Steve McMahon's code at
' http://www.vbaccelerator.com/codelib/gfx/imgproc2.htm
' Steve's conversion is perfect and yields excellent results.
' Steve's site copyright notice is at:
' http://www.vbaccelerator.com/mission.htm
'
'
'
'BUGS: Please report any bugs to my email address.
'
'What's Missing:
' Proper error handling.
' GUI interface to set colors.
'
'
'How it Works:
' We create a DIB(Bitmap) that exactly matches the dimensions
' of the Image control. This Bitmap is then set as the
' the Image control's PictureData Property. By exposing a
' handle to a Device Context the user/developer can now
' use the GDI API's on the DIBSection.
'
'
' Remember, in life you get what you pay for.
' Please remember what you paid for this code!<grin>
'
' Enjoy!
' Stephen Lebans
Private Const LF_FACESIZE = 32
Private Type SizeX2
cx As Long
cy As Long
widthX As Long
widthY As Long
End Type
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * LF_FACESIZE
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type SIZEL
cx As Long
cy As Long
End Type
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgblReterved As Byte
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 'ERGBCompression
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private 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 DIBSECTION
dsBm As BITMAP
dsBmih As BITMAPINFOHEADER
dsBitfields(2) As Long
dshSection As Long
dsOffset As Long
End Type
' Here is the header for the Bitmap file
' as it resides in a disk file
Private Type BITMAPFILEHEADER '14 bytes
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
' Logical Brush (or Pattern)
Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Private Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type ENHMETAHEADER
iType As Long
nSize As Long
rclBounds As RECT
rclFrame As RECT
dSignature As Long
nVersion As Long
nBytes As Long
nRecords As Long
nHandles As Integer
sReserved As Integer
nDescription As Long
offDescription As Long
nPalEntries As Long
szlDevice As SIZEL
szlMillimeters As SIZEL
End Type
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private 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
Private Type METAFILEPICT
mm As Long
xExt As Long
yExt As Long
hMF As Long
End Type
'
Private Declare Function SetEnhMetaFileBits Lib "gdi32" _
(ByVal cbBuffer As Long, lpData As Byte) As Long
Private Declare Function SetWinMetaFileBits Lib "gdi32" _
(ByVal cbBuffer As Long, lpbBuffer As Byte, _
ByVal hDCRef As Long, lpmfp As Any) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Function Rectangle Lib "gdi32" _
(ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, _
ByVal x2 As Long, ByVal y2 As Long) As Long
Private Declare Function SetROP2 Lib "gdi32" _
(ByVal hdc As Long, ByVal nDrawMode As Long) As Long
Private Declare Function LineTo Lib "gdi32" _
(ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function apiGetStockObject Lib "gdi32" Alias "GetStockObject" _
(ByVal nIndex As Long) As Long
Private Declare Function apiBitBlt Lib "gdi32" _
Alias "BitBlt" (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
Private Declare Function apiDrawText 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
Private Declare Function apiCreatePen Lib "gdi32" Alias "CreatePen" _
(ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function apiRoundRect Lib "gdi32" Alias "RoundRect" _
(ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, _
ByVal x2 As Long, ByVal y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function apiFloodFill Lib "gdi32" Alias "FloodFill" _
(ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function apiEllipse Lib "gdi32" _
Alias "Ellipse" _
(ByVal hdc As Long, _
ByVal Left As Long, _
ByVal Top As Long, _
ByVal Right As Long, _
ByVal Bottom As Long) _
As Long
Private Declare Function apiArc Lib "gdi32" _
Alias "Arc" _
(ByVal hdc As Long, _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal x2 As Long, _
ByVal y2 As Long, _
ByVal X3 As Long, _
ByVal Y3 As Long, _
ByVal X4 As Long, _
ByVal Y4 As Long) _
As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function PolyPolyline Lib "gdi32" (ByVal hdc As Long, lppt As POINTAPI, lpdwPolyPoints As Long, ByVal cCount As Long) As Long
Private Declare Function PolylineTo Lib "gdi32" (ByVal hdc As Long, lppt As POINTAPI, ByVal cCount As Long) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long
Private Declare Function apiSetTextAlign Lib "gdi32" Alias "SetTextAlign" _
(ByVal hdc As Long, ByVal wFlags As Long) As Long
Private Declare Function apiSetTextColor Lib "gdi32" Alias "SetTextColor" _
(ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function apiSetBkColor Lib "gdi32" Alias "SetBkColor" _
(ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" _
(ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function apiGetTextExtentPoint32 Lib "gdi32" _
Alias "GetTextExtentPoint32A" _
(ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, _
lpsize As SIZEL) As Long
Private Declare Function apiTextOut 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
Private Declare Function apiCreateFontIndirect Lib "gdi32" Alias _
"CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function apiMoveToEx Lib "gdi32" Alias "MoveToEx" _
(ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As Any) As Long
'above was lpPoint as POINTAPI, changed to Any to allow NULL
' Note - this is not the declare in the API viewer - modify lplpVoid to be
' Byref so we get the pointer back:
Private Declare Function CreateDIBSection Lib "gdi32" _
(ByVal hdc As Long, pBitmapInfo As BITMAPINFO, _
ByVal un As Long, lplpVoid As Long, ByVal handle As Long, _
ByVal dw As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc 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
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
Private Declare Function apiGetObject Lib "gdi32" _
Alias "GetObjectA" _
(ByVal hObject As Long, ByVal nCount As Long, _
lpObject As Any) As Long
Private Declare Sub apiCopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function apiGetDeviceCaps Lib "gdi32" _
Alias "GetDeviceCaps" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function apiCreateSolidBrush Lib "gdi32" _
Alias "CreateSolidBrush" _
(ByVal crColor As Long) As Long
Private Declare Function apiFillRect Lib "user32" Alias "FillRect" _
(ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function GetSysColor Lib "user32" _
(ByVal nIndex As Long) As Long
Private Declare Function GetSysColorBrush Lib "user32" _
(ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function SetPixel Lib "gdi32" _
(ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, _
ByVal crColor As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" _
(ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, _
ByVal crColor As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" _
(ByVal hdc As Long, ByVal hBMP As Long, ByVal uStartScan As Long, _
ByVal cScanLines As Long, ByVal lpvBits As Long, _
ByRef lpBI As BITMAPINFO, ByVal uUsage As Long) As Long
Private Declare Function LoadImage Lib "user32" _
Alias "LoadImageA" (ByVal hInstance As Long, ByVal Name As Long, _
ByVal uType As Long, ByVal cxDesired As Long, _
ByVal cyDesired As Long, ByVal fuLoad As Long) As Long
'Private Declare Function StretchBlt Lib "gdi32" (ByVal DestDC 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 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 PlayEnhMetaFile Lib "gdi32" _
(ByVal hdc As Long, ByVal hemf As Long, lpRect As RECT) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hemf As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
(ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function Polygon Lib "gdi32" _
(ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Private Declare Function GetEnhMetaFileHeader Lib "gdi32" _
(ByVal hemf As Long, ByVal cbBuffer As Long, lpemh As ENHMETAHEADER) As Long
Private Declare Function GlobalAlloc Lib "kernel32" _
(ByVal wFlags&, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat _
As Long, ByVal hMem As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
'Global Memory Flags
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GMEM_SHARE = &H2000
' -------------
' GDI Section
' -------------
' Binary raster ops
Private Const R2_BLACK = 1 ' 0
Private Const R2_NOTMERGEPEN = 2 ' DPon
Private Const R2_MASKNOTPEN = 3 ' DPna
Private Const R2_NOTCOPYPEN = 4 ' PN
Private Const R2_MASKPENNOT = 5 ' PDna
Private Const R2_NOT = 6 ' Dn
Private Const R2_XORPEN = 7 ' DPx
Private Const R2_NOTMASKPEN = 8 ' DPan
Private Const R2_MASKPEN = 9 ' DPa
Private Const R2_NOTXORPEN = 10 ' DPxn
Private Const R2_NOP = 11 ' D
Private Const R2_MERGENOTPEN = 12 ' DPno
Private Const R2_COPYPEN = 13 ' P
Private Const R2_MERGEPENNOT = 14 ' PDno
Private Const R2_MERGEPEN = 15 ' DPo
Private Const R2_WHITE = 16 ' 1
Private Const R2_LAST = 16
' DrawText() Format Flags
Private Const DT_TOP = &H0
Private Const DT_LEFT = &H0
Private Const DT_CENTER = &H1
Private Const DT_RIGHT = &H2
Private Const DT_VCENTER = &H4
Private Const DT_BOTTOM = &H8
Private Const DT_WORDBREAK = &H10
Private Const DT_SINGLELINE = &H20
Private Const DT_EXPANDTABS = &H40
Private Const DT_TABSTOP = &H80
Private Const DT_NOCLIP = &H100
Private Const DT_EXTERNALLEADING = &H200
Private Const DT_CALCRECT = &H400
Private Const DT_NOPREFIX = &H800
Private Const DT_INTERNAL = &H1000
'TextAlign Flags
Private Const TA_UPDATECP = 1
'ERGBCompression Types
Private Const BI_RGB = 0&
Private Const BI_RLE4 = 2&
Private Const BI_RLE8 = 1&
Private Const DIB_RGB_COLORS = 0
' Brush Styles
'Private Const BS_SOLID = 0
' Background Modes
Private Const TRANSPARENT = 1
Private Const OPAQUE = 2
Private Const BKMODE_LAST = 2
' Predefined Clipboard Formats
Private Const CF_TEXT = 1
Private Const CF_BITMAP = 2
Private Const CF_METAFILEPICT = 3
Private Const CF_SYLK = 4
Private Const CF_DIF = 5
Private Const CF_TIFF = 6
Private Const CF_OEMTEXT = 7
Private Const CF_DIB = 8
Private Const CF_PALETTE = 9
Private Const CF_PENDATA = 10
Private Const CF_RIFF = 11
Private Const CF_WAVE = 12
Private Const CF_UNICODETEXT = 13
Private Const CF_ENHMETAFILE = 14
' Device Parameters for GetDeviceCaps()
Private Const LOGPIXELSX = 88 ' Logical pixels/inch in X
Private Const LOGPIXELSY = 90 ' Logical pixels/inch in Y
Private Const BITSPIXEL = 12 ' Number of bits per pixel
Const HORZRES = 8 ' Horizontal width in pixels
Const VERTRES = 10 ' Vertical width in pixels
' For ConvertTwipsToPixels
Private Const Horiz = 0
Private Const Vert = 1
' Stock Logical Objects
Private Const WHITE_BRUSH = 0
Private Const LTGRAY_BRUSH = 1
Private Const GRAY_BRUSH = 2
Private Const DKGRAY_BRUSH = 3
Private Const BLACK_BRUSH = 4
Private Const NULL_BRUSH = 5
Private Const HOLLOW_BRUSH = NULL_BRUSH
Private Const WHITE_PEN = 6
Private Const BLACK_PEN = 7
Private Const NULL_PEN = 8
Private Const OEM_FIXED_FONT = 10
Private Const ANSI_FIXED_FONT = 11
Private Const ANSI_VAR_FONT = 12
Private Const SYSTEM_FONT = 13
Private Const DEVICE_DEFAULT_FONT = 14
Private Const DEFAULT_PALETTE = 15
Private Const SYSTEM_FIXED_FONT = 16
Private Const STOCK_LAST = 16
Private Const CLR_INVALID = &HFFFF
' Brush Styles
Private Const BS_SOLID = 0
Private Const BS_NULL = 1
Private Const BS_HOLLOW = BS_NULL
Private Const BS_HATCHED = 2
Private Const BS_PATTERN = 3
Private Const BS_INDEXED = 4
Private Const BS_DIBPATTERN = 5
Private Const BS_DIBPATTERNPT = 6
Private Const BS_PATTERN8X8 = 7
Private Const BS_DIBPATTERN8X8 = 8
' Hatch Styles
Private Const HS_HORIZONTAL = 0 ' -----
Private Const HS_VERTICAL = 1 ' |||||
Private Const HS_FDIAGONAL = 2 ' \\\\\
Private Const HS_BDIAGONAL = 3 ' /////
Private Const HS_CROSS = 4 ' +++++
Private Const HS_DIAGCROSS = 5 ' xxxxx
Private Const HS_FDIAGONAL1 = 6
Private Const HS_BDIAGONAL1 = 7
Private Const HS_SOLID = 8
Private Const HS_DENSE1 = 9
Private Const HS_DENSE2 = 10
Private Const HS_DENSE3 = 11
Private Const HS_DENSE4 = 12
Private Const HS_DENSE5 = 13
Private Const HS_DENSE6 = 14
Private Const HS_DENSE7 = 15
Private Const HS_DENSE8 = 16
Private Const HS_NOSHADE = 17
Private Const HS_HALFTONE = 18
Private Const HS_SOLIDCLR = 19
Private Const HS_DITHEREDCLR = 20
Private Const HS_SOLIDTEXTCLR = 21
Private Const HS_DITHEREDTEXTCLR = 22
Private Const HS_SOLIDBKCLR = 23
Private Const HS_DITHEREDBKCLR = 24
Private Const HS_API_MAX = 25
' Pen Styles
Private Const PS_SOLID = 0
Private Const PS_DASH = 1 ' -------
Private Const PS_DOT = 2 ' .......
Private Const PS_DASHDOT = 3 ' _._._._
Private Const PS_DASHDOTDOT = 4 ' _.._.._
Private Const PS_NULL = 5
Private Const PS_INSIDEFRAME = 6
Private Const PS_USERSTYLE = 7
Private Const PS_ALTERNATE = 8
Private Const PS_STYLE_MASK = &HF
Private Const PS_ENDCAP_ROUND = &H0
Private Const PS_ENDCAP_SQUARE = &H100
Private Const PS_ENDCAP_FLAT = &H200
Private Const PS_ENDCAP_MASK = &HF00
Private Const PS_JOIN_ROUND = &H0
Private Const PS_JOIN_BEVEL = &H1000
Private Const PS_JOIN_MITER = &H2000
Private Const PS_JOIN_MASK = &HF000
Private Const PS_COSMETIC = &H0
Private Const PS_GEOMETRIC = &H10000
Private Const PS_TYPE_MASK = &HF0000
' Font stuff
Private Const OUT_DEFAULT_PRECIS = 0
Private Const OUT_STRING_PRECIS = 1
Private Const OUT_CHARACTER_PRECIS = 2
Private Const OUT_STROKE_PRECIS = 3
Private Const OUT_TT_PRECIS = 4
Private Const OUT_DEVICE_PRECIS = 5
Private Const OUT_RASTER_PRECIS = 6
Private Const OUT_TT_ONLY_PRECIS = 7
Private Const OUT_OUTLINE_PRECIS = 8
Private Const CLIP_DEFAULT_PRECIS = 0
Private Const CLIP_CHARACTER_PRECIS = 1
Private Const CLIP_STROKE_PRECIS = 2
Private Const CLIP_MASK = &HF
Private Const CLIP_LH_ANGLES = 16
Private Const CLIP_TT_ALWAYS = 32
Private Const CLIP_EMBEDDED = 128
Private Const DEFAULT_QUALITY = 0
Private Const DRAFT_QUALITY = 1
Private Const PROOF_QUALITY = 2
Private Const DEFAULT_PITCH = 0
Private Const FIXED_PITCH = 1
Private Const VARIABLE_PITCH = 2
Private Const ANSI_CHARSET = 0
Private Const DEFAULT_CHARSET = 1
Private Const SYMBOL_CHARSET = 2
Private Const SHIFTJIS_CHARSET = 128
Private Const HANGEUL_CHARSET = 129
Private Const CHINESEBIG5_CHARSET = 136
Private Const OEM_CHARSET = 255
' From winuser.h
Private Const IMAGE_BITMAP = 0
Private Const IMAGE_ICON = 1
Private Const IMAGE_CURSOR = 2
Private Const IMAGE_ENHMETAFILE = 3
Private Const LR_DEFAULTCOLOR = &H0
Private Const LR_MONOCHROME = &H1
Private Const LR_COLOR = &H2
Private Const LR_COPYRETURNORG = &H4
Private Const LR_COPYDELETEORG = &H8
Private Const LR_LOADFROMFILE = &H10
Private Const LR_LOADTRANSPARENT = &H20
Private Const LR_DEFAULTSIZE = &H40
Private Const LR_VGACOLOR = &H80
Private Const LR_LOADMAP3DCOLORS = &H1000
Private Const LR_CREATEDIBSECTION = &H2000
Private Const LR_COPYFROMRESOURCE = &H4000
Private Const LR_SHARED = &H8000
' Ternary raster operations
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Const vbSrcCopy = &HCC0020
Private Const SRCPAINT = &HEE0086 ' (DWORD) dest = source OR dest
Private Const SRCAND = &H8800C6 ' (DWORD) dest = source AND dest
Private Const SRCINVERT = &H660046 ' (DWORD) dest = source XOR dest
Private Const SRCERASE = &H440328 ' (DWORD) dest = source AND (NOT dest )
Private Const NOTSRCCOPY = &H330008 ' (DWORD) dest = (NOT source)
Private Const NOTSRCERASE = &H1100A6 ' (DWORD) dest = (NOT src) AND (NOT dest)
Private Const MERGECOPY = &HC000CA ' (DWORD) dest = (source AND pattern)
Private Const MERGEPAINT = &HBB0226 ' (DWORD) dest = (NOT source) OR dest
Private Const PATCOPY = &HF00021 ' (DWORD) dest = pattern
Private Const PATPAINT = &HFB0A09 ' (DWORD) dest = DPSnoo
Private Const PATINVERT = &H5A0049 ' (DWORD) dest = pattern XOR dest
Private Const DSTINVERT = &H550009 ' (DWORD) dest = (NOT dest)
Private Const BLACKNESS = &H42 ' (DWORD) dest = BLACK
Private Const WHITENESS = &HFF0062 ' (DWORD) dest = WHITE
' Misc constants
Private Const PI = 3.14159265
Private Const PI_180 = PI / 180#
Private Const PI_2 = PI / 2#
' Class vars
' Handle to the current DIBSection:
Private m_hDIb As Long
Private m_hDib2 As Long
' Handle to the old bitmap in the DC, for clear up:
Private m_hBmpOld As Long
Private m_hBmpOld2 As Long
' Handle to the Device context holding the DIBSection:
Private m_hDC As Long
Private m_hDC2 As Long
' Address of memory pointing to the DIBSection's bits:
Private m_lPtr As Long
Private m_lPtr2 As Long
' Type containing the Bitmap information:
Private m_bmi As BITMAPINFO
Private m_bmi2 As BITMAPINFO
' Detail Section Height in Pixels
Private m_ImageHeight As Long
' Detail Section Width in Pixels
Private m_ImageWidth As Long
' Hold reference to our Parent Form
Private m_ImageForm As Access.Form
' Control we will use for our Criteria matching
Private WithEvents m_ImageControl As Access.Image
' Screen horizontal Resolution
Dim m_ScreenXdpi As Long
' Screen Vertical Resolution
Dim m_ScreenYdpi As Long
' Degrees of Rotation for Text to be drawn
' onto the upper part of the TAB control
Private m_RotateDegree As Long
' Text Foreground color
Private m_ForeColor As Long
' Text Background color
Private m_BackColor As Long
' Text Background mode
Private m_BackMode As Long
' Background color for Image control
Private m_FillColor As Long
' DrawMode for Image control
Private m_DrawMode As Long
' Previous DrawMode for Image control
Private m_PrevDrawMode As Long
' DrawStyle for Image control
Private m_DrawStyle As Long
' DrawWidth for Image control
Private m_DrawWidth As Long
' FontName for Image control
Private m_FontName As String
' FontSize for Image control
Private m_FontSize As Long
' FontWeight for Image control
Private m_FontWeight As Long
' FontBold for Image control
Private m_FontBold As Boolean
' FontItalic for Image control
Private m_FontItalic As Boolean
' FontUnderline for Image control
Private m_FontUnderline As Boolean
' Are we drawing with the Mouse?
Private m_MouseDraw As Boolean
' Spacing in Pixels between columns of Text
Private m_Spacing As Long
' Flag to signify move CurrentX & Y to cursor Position
Private m_StartDrawing As Boolean
' Scaling factor
Private m_PicScale As Single
' Do we NOT use the parent of the hWnd passed
' to the ScreenCapture method
' Default = False ->We use the parent
Private m_DoNotUseParent As Boolean
' Points array for drawing polygons
Dim m_Points() As POINTAPI
' Temp vars
Dim lngRet As Long
Dim blRet As Boolean
Public Property Get ImageForm() As Access.Form
' Number of rows displayed in the Form
Set ImageForm = m_ImageForm
End Property
Public Property Let ImageForm(frm As Access.Form)
' Pass a reference to the actual Form.
Set m_ImageForm = Nothing
Set m_ImageForm = frm
End Property
Public Property Get ImageControl() As Control
Set ImageControl = m_ImageControl
End Property
Public Property Let ImageControl(ctl As Control)
' Pass a reference to the actual control.
' Need to make this a collection to allow for
' the selection of multiple controls
Set m_ImageControl = Nothing
Set m_ImageControl = ctl
' Sink the desired event(s)
m_ImageControl.OnMouseDown = "[Event Procedure]"
m_ImageControl.OnMouseMove = "[Event Procedure]"
m_ImageControl.OnMouseUp = "[Event Procedure]"
' Set defaults for Image control
' Embedded
m_ImageControl.PictureType = 0
' Align Left
m_ImageControl.PictureAlignment = 0
' Clip
m_ImageControl.SizeMode = 0
' Create DIBSection
blRet = Create()
If Not blRet Then
MsgBox "Unable to create DIBSection"
End If
End Property
Public Property Get BytesPerScanLine() As Long
' Scans must align on dword boundaries:
BytesPerScanLine = (m_bmi.bmiHeader.biWidth * (m_bmi.bmiHeader.biBitCount / 8) + 3) And &HFFFFFFFC
End Property
Public Property Get dib_width() As Long
dib_width = m_bmi.bmiHeader.biWidth
End Property
Public Property Get dib_height() As Long
dib_height = m_bmi.bmiHeader.biHeight
End Property
Public Property Get dib_channels() As Long
dib_channels = m_bmi.bmiHeader.biBitCount / 8
End Property
Public Property Get hdc() As Long
hdc = m_hDC
End Property
Public Property Get hDib() As Long
hDib = m_hDIb
End Property
Public Property Get DIBSectionBitsPtr() As Long
DIBSectionBitsPtr = m_lPtr
End Property
Public Property Get RotateDegree() As Variant
RotateDegree = m_RotateDegree
End Property
Public Property Let RotateDegree(ByVal X As Variant)
Dim deg As Long
deg = Val(X)
Select Case deg
Case Is < 0
m_RotateDegree = 0
Case Is < 359
m_RotateDegree = deg
Case Is >= 359
m_RotateDegree = 0
Case Else
m_RotateDegree = 0
End Select
End Property
Public Property Get DoNotUseParent() As Boolean
' Default = False. We do get the parent of the
' hWnd passed to the CaptureScreen method.
m_DoNotUseParent = m_DoNotUseParent
End Property
Public Property Let DoNotUseParent(ByVal bl As Boolean)
m_DoNotUseParent = bl
End Property
Public Property Get DrawStyle() As Long
DrawStyle = m_DrawStyle
End Property
Public Property Let DrawStyle(ByVal X As Long)
m_DrawStyle = X
End Property
Public Property Get DrawWidth() As Long
DrawWidth = m_DrawWidth
End Property
Public Property Let DrawWidth(ByVal X As Long)
m_DrawWidth = X
End Property
Public Property Get DrawMode() As Long
DrawMode = m_DrawMode
End Property
Public Property Let DrawMode(ByVal X As Long)
If X < 17 Then
If X > 0 Then
m_DrawMode = X
' Set ROP mode for DC
m_PrevDrawMode = SetROP2(m_hDC, X)
End If
End If
End Property
Public Property Get ForeColor() As Long
ForeColor = m_ForeColor
End Property
Public Property Let ForeColor(ByVal X As Long)
m_ForeColor = X
End Property
Public Property Get BackColor() As Long
BackColor = m_BackColor
End Property
Public Property Let BackColor(ByVal X As Long)
m_BackColor = X
End Property
Public Property Get BackMode() As Long
BackMode = m_BackMode
End Property
Public Property Let BackMode(ByVal X As Long)
m_BackMode = X
End Property
Public Property Get FillColor() As Long
FillColor = m_FillColor
End Property
Public Property Let FillColor(ByVal X As Long)
m_FillColor = X
End Property
Public Property Get FontItalic() As Boolean
FontItalic = m_FontItalic
End Property
Public Property Let FontItalic(ByVal X As Boolean)
m_FontItalic = X
End Property
Public Property Get FontBold() As Boolean
FontBold = m_FontBold
End Property
Public Property Let FontBold(ByVal X As Boolean)
m_FontBold = X
' Set Font Weight to Bold
m_FontWeight = 700
End Property
Public Property Get FontWeight() As Long
FontWeight = m_FontWeight
End Property
Public Property Let FontWeight(ByVal X As Long)
m_FontWeight = X
End Property
Public Property Get FontUnderline() As Boolean
FontUnderline = m_FontUnderline
End Property
Public Property Let FontUnderline(ByVal X As Boolean)
m_FontUnderline = X
End Property
Public Property Get FontSize() As Long
FontSize = m_FontSize
End Property
Public Property Let FontSize(ByVal X As Long)
m_FontSize = X
End Property
Public Property Get FontName() As String
FontSize = m_FontName
End Property
Public Property Let FontName(ByVal nm As String)
m_FontName = nm
End Property
Public Property Get MouseDraw() As Boolean
MouseDraw = m_MouseDraw
End Property
Public Property Let MouseDraw(ByVal X As Boolean)
m_MouseDraw = X
End Property
Public Property Get Spacing() As Long
Spacing = m_Spacing
End Property
Public Property Let Spacing(ByVal X As Long)
m_Spacing = X
End Property
Public Property Get PicScale() As Single
PicScale = m_PicScale
End Property
Public Property Let PicScale(ByVal X As Single)
m_PicScale = X
End Property
Public Function CreateDIB( _
ByVal lHDC As Long, _
ByVal lWidth As Long, _
ByVal lHeight As Long, _
ByVal lchannels As Long, _
ByRef hDib As Long _
) As Boolean
' Minimum 16 bits otherwise a 24 bit DIB created.
With m_bmi.bmiHeader
.biSize = Len(m_bmi.bmiHeader)
.biWidth = lWidth
.biHeight = lHeight
.biPlanes = 1
' If lchannels = 3 Then
' .biBitCount = 24
' ElseIf lchannels = 2 Then
' .biBitCount = 16
'
' Else
' .biBitCount = 32
' End If
' **** ALWAYS 24 BIT for this Class.
' Guarantees compatability
.biBitCount = 24
.biCompression = BI_RGB
.biSizeImage = BytesPerScanLine * .biHeight
End With
' Copy first Bitmapheader to second
With m_bmi2
.bmiHeader.biBitCount = m_bmi.bmiHeader.biBitCount
.bmiHeader.biCompression = m_bmi.bmiHeader.biCompression
.bmiHeader.biHeight = m_bmi.bmiHeader.biHeight
.bmiHeader.biWidth = m_bmi.bmiHeader.biWidth
.bmiHeader.biPlanes = m_bmi.bmiHeader.biPlanes
.bmiHeader.biSize = m_bmi.bmiHeader.biSize
.bmiHeader.biSizeImage = m_bmi.bmiHeader.biSizeImage
End With
' Create our DIBSection
hDib = CreateDIBSection(m_hDC, m_bmi, DIB_RGB_COLORS, m_lPtr, 0, 0)
m_hDib2 = CreateDIBSection(m_hDC2, m_bmi2, DIB_RGB_COLORS, m_lPtr2, 0, 0)
CreateDIB = (hDib <> 0)
End Function
Public Function Create(Optional ClearBackground As Boolean = True, _
Optional GetDimensions As Boolean = True) As Boolean
Dim lchannels As Long
' Re-init all vars
CleanUp
If GetDimensions Then
' Get Dimensions of the Form's Header & Detail Section
GetDIBDimensions
End If
' Create a DC compatible with the current display
m_hDC = CreateCompatibleDC(0&)
' Create a second DC compatible with the current display
m_hDC2 = CreateCompatibleDC(0&)
' Usually will be 3 channels
' Always 3 channels(24 bits) for this Class
lchannels = 3 'GetBitsPerPixel / 8
' Create the DIBSection
If (m_hDC <> 0) Then
If (CreateDIB(m_hDC, m_ImageWidth, m_ImageHeight, lchannels, m_hDIb)) Then
m_hBmpOld = SelectObject(m_hDC, m_hDIb)
m_hBmpOld2 = SelectObject(m_hDC2, m_hDib2)
Create = True
Else
Call DeleteObject(m_hDC)
Call DeleteObject(m_hDC2)
m_hDC = 0
m_hDC2 = 0
End If
End If
' Clear the Dib to selected Fill color
' is the default action. If we have arrived here
' though by the user loading a picture directly
' into the Image control then we do not clear
' the background.
If ClearBackground Then
Clear
End If
End Function
Public Function DIBtoPictureData(Optional DIBnum As Long = 0) As Boolean
' DIBSECTION structure
Dim ds As DIBSECTION
' Array to hold Byte data formatted as
' CF_DIB for the PictureData property
Dim varTemp() As Byte
If DIBnum = 0 Then
' Fill in our DIBSECTION structure
lngRet = apiGetObject(hDib, Len(ds), ds)
Else
' Fill in our DIBSECTION structure for our Backup DIB
lngRet = apiGetObject(m_hDib2, Len(ds), ds)
End If
' Allow 40 Bytes for the DIBHeader
ReDim varTemp(ds.dsBmih.biSizeImage + 40)
If DIBnum = 0 Then
apiCopyMemory varTemp(40), ByVal m_lPtr, ds.dsBmih.biSizeImage
Else
apiCopyMemory varTemp(40), ByVal m_lPtr2, ds.dsBmih.biSizeImage
End If
apiCopyMemory varTemp(0), ds.dsBmih, 40
' Update the PictureData property of the Image control
m_ImageControl.PictureData = varTemp
'Debug.Print "Updated PictureData Prop:" & Now
End Function
Public Function DIBFlipHorizontal() As Boolean
' DIBSECTION structure
Dim ds As DIBSECTION
' Loop ctr
Dim X As Long
' Width of single row if Image in Bytes
Dim lngWB As Long
' Fill in our DIBSECTION structure
lngRet = apiGetObject(hDib, Len(ds), ds)
' Grab the Image width in bytes
lngWB = ds.dsBm.bmWidthBytes
' Copy 1 complete row at a time from our
' main DC to our backup DC.
' We Flip the Image by copying the first row to the last etc.
For X = 1 To ds.dsBmih.biHeight
apiCopyMemory ByVal m_lPtr2 + (ds.dsBmih.biSizeImage - (lngWB * X)), ByVal m_lPtr + (lngWB * (X - 1)), lngWB
Next
' Now copy backup DC to Main Dc
apiCopyMemory ByVal m_lPtr, ByVal m_lPtr2, ds.dsBmih.biSizeImage
' Update the PictureData property of the Image control
DIBtoPictureData
End Function
Public Function DIBMirrorX() As Boolean
' Use the StretchBlt API to Flip the Image and Mirror it Horizontally
' DIBSECTION structure
Dim ds As DIBSECTION
' Fill in our DIBSECTION structure
lngRet = apiGetObject(hDib, Len(ds), ds)
' Clear the backup Buffer
lngRet = apiBitBlt(m_hDC2, 0, 0, dib_width, dib_height, _
0&, 0, 0, WHITENESS)
' Blit the entire Bitmap and mirror along X axis to backup buffer
lngRet = StretchBlt(m_hDC2, 0, 0, dib_width, dib_height, _
m_hDC, dib_width, 0, -(dib_width), dib_height, vbSrcCopy)
' Now copy backup DC to Main Dc
apiCopyMemory ByVal m_lPtr, ByVal m_lPtr2, ds.dsBmih.biSizeImage
' Update the PictureData property of the Image control
DIBtoPictureData
End Function
Public Function DIBMirrorY() As Boolean
' Use the StretchBlt API to Flip the Image and Mirror it Vertically
' DIBSECTION structure
Dim ds As DIBSECTION
' Fill in our DIBSECTION structure
lngRet = apiGetObject(hDib, Len(ds), ds)
' Clear the backup Buffer
lngRet = apiBitBlt(m_hDC2, 0, 0, dib_width, dib_height, _
0&, 0, 0, WHITENESS)
' Blit the entire Bitmap and mirror along X axis to backup buffer
lngRet = StretchBlt(m_hDC2, 0, 0, dib_width, (dib_height), _
m_hDC, 0, dib_height, dib_width, -(dib_height), vbSrcCopy)
' Now copy backup DC to Main Dc
apiCopyMemory ByVal m_lPtr, ByVal m_lPtr2, ds.dsBmih.biSizeImage
' Update the PictureData property of the Image control
DIBtoPictureData
End Function
Public Sub CleanUp()
' Release and delete all
' objects before we go to
' create our DIBSection.
If (m_hDC <> 0) Then
If (m_hDIb <> 0) Then
Call SelectObject(m_hDC, m_hBmpOld)
Call SelectObject(m_hDC2, m_hBmpOld2)
Call DeleteObject(m_hDIb)
Call DeleteObject(m_hDib2)
End If
Call DeleteObject(m_hDC)
Call DeleteObject(m_hDC2)
End If
m_hDC = 0
m_hDC2 = 0
m_hDIb = 0
m_hDib2 = 0
m_hBmpOld = 0
m_hBmpOld2 = 0
m_lPtr = 0
m_lPtr2 = 0
m_bmi.bmiColors.rgbBlue = 0
m_bmi.bmiColors.rgbGreen = 0
m_bmi.bmiColors.rgbRed = 0
m_bmi.bmiColors.rgblReterved = 0
m_bmi.bmiHeader.biSize = Len(m_bmi.bmiHeader)
m_bmi.bmiHeader.biWidth = 0
m_bmi.bmiHeader.biHeight = 0
m_bmi.bmiHeader.biPlanes = 0
m_bmi.bmiHeader.biBitCount = 0
m_bmi.bmiHeader.biClrUsed = 0
m_bmi.bmiHeader.biClrImportant = 0
m_bmi.bmiHeader.biCompression = 0
End Sub
Private Sub GetDIBDimensions()
' Here we ascertain the size of
' Image control.
'
' Check and see if the ImageWidth prop
' is zero. This tells us a Picture is not loaded into the control
' so we use the Control's Dimensions otherwise we use the
' loaded picture's dimensions.
On Error Resume Next
If m_ImageControl.ImageWidth = 0 Then
m_ImageWidth = TwipsToPixels(m_ImageControl.Width, Horiz)
m_ImageHeight = TwipsToPixels(m_ImageControl.Height, Vert)
Else
' use the ImageWidth and Height props. Must check
' for allowable values as I have seen garbage in these props.
If m_ImageControl.ImageWidth > 0 And m_ImageControl.ImageWidth < 32000 Then
If m_ImageControl.ImageHeight > 0 And m_ImageControl.ImageHeight < 32000 Then
m_ImageWidth = TwipsToPixels(m_ImageControl.ImageWidth, Horiz)
m_ImageHeight = TwipsToPixels(m_ImageControl.ImageHeight, Vert)
Else
m_ImageWidth = TwipsToPixels(m_ImageControl.Width, Horiz)
m_ImageHeight = TwipsToPixels(m_ImageControl.Height, Vert)
End If
End If
End If
End Sub
Function TwipsToPixels(lngTwips As Long, _
lngDirection As Long) As Long
'Handle to device
Dim lngDC As Long
Dim lngPixelsPerInch As Long
Const nTwipsPerInch = 1440
lngDC = GetDC(0)
If (lngDirection = 0) Then 'Horizontal
lngPixelsPerInch = apiGetDeviceCaps(lngDC, LOGPIXELSX)
Else 'Vertical
lngPixelsPerInch = apiGetDeviceCaps(lngDC, LOGPIXELSY)
End If
lngDC = ReleaseDC(0, lngDC)
TwipsToPixels = (lngTwips / nTwipsPerInch) * lngPixelsPerInch
End Function
Private Function GetBitsPerPixel() As Long
Dim lngDC As Long
Dim lngBits As Long
On Error Resume Next
' Get screen DC
lngDC = GetDC(0)
' Get current Bits per pixel
lngBits = apiGetDeviceCaps(lngDC, BITSPIXEL)
'Release the DC.
Call ReleaseDC(0&, lngDC)
' Return value
If lngBits <> 0 Then
GetBitsPerPixel = lngBits
Else
GetBitsPerPixel = 24
End If
End Function
Public Sub UpdateScreen()
' Copy the bits from our DIBSection to the
' PictureData property of this TAB Page
DIBtoPictureData
End Sub
Public Sub Clear()
' Clear the DIBSection to existing Form's Background Color
' *** CHANGE THIS TO SELECTED FILL COLOR ***
Dim hNewBrush As Long
Dim hSystemBrush As Long
Dim rc As RECT
Dim lb As LOGBRUSH
hSystemBrush = 0
hNewBrush = 0
Dim lngColor As Long
Dim rgbRed As Long, rgbGreen As Long, rgbBlue As Long
lngColor = m_BackColor
If lngColor And &H80000000 Then
hSystemBrush = GetSysColorBrush(lngColor And &HFFFFFF)
'hSystemBrush = (m_HeaderBackgroundColor And &HFFFFFF) + 1
Else
lb.lbColor = lngColor
lb.lbStyle = BS_SOLID
hNewBrush = CreateBrushIndirect(lb)
'hNewBrush = apiCreateSolidBrush(RGB(rgbRed, rgbGreen, rgbBlue))
End If
' Get the Rectangle dimensions from our DIBSection
rc.Left = 0
rc.Top = 0
rc.Right = dib_width
rc.Bottom = dib_height
If hNewBrush <> 0 Then
lngRet = apiFillRect(m_hDC, rc, hNewBrush)
Else
lngRet = apiFillRect(m_hDC, rc, hSystemBrush)
End If
' Don't delete System Brush only brush created with CreateSolidBrush
If hNewBrush <> 0 Then
Call DeleteObject(hNewBrush)
End If
' Update display.
' Copy the bits from our DIBSection to the
' PictureData property of the Image control
DIBtoPictureData
End Sub
Public Function OutputText(Optional ByVal strText As String = "") As Boolean
'*******************************************
' Draws the Text and updates the PictureData property
On Error GoTo ErrHandler
'GDI Handles
Dim hFont As Long, prevfont As Long
'To create our Rotated Font
Dim strname As String
Dim FontSize As Long
Dim lnglength As Long
Dim stfsize As SIZEL
Dim lpsz As SizeX2
Dim myfont As LOGFONT
Dim lngTextWidth As Long
' RECT structure
Dim lpRect As RECT
' Clear Image control to background color
Clear
'OK setup font and print into the supplied bitmap
'Escapement = rotation is specified in tenths of a degree
myfont.lfClipPrecision = CLIP_LH_ANGLES
myfont.lfOutPrecision = OUT_TT_ONLY_PRECIS
myfont.lfEscapement = Abs(m_RotateDegree) * 10
myfont.lfFaceName = m_FontName & Chr$(0) 'Null character at end
'Copy font stuff from Text Control's property sheet
FontSize = m_FontSize
myfont.lfWeight = m_FontWeight
myfont.lfItalic = m_FontItalic
myfont.lfUnderline = m_FontUnderline
'Must be a negative figure for height or system will return
'closest match on character cell not glyph
myfont.lfHeight = (FontSize / 72) * -m_ScreenXdpi
hFont = apiCreateFontIndirect(myfont)
prevfont = SelectObject(m_hDC, hFont)
'Let's get length and height of non rotated of output string
lnglength = Len(strText)
lngRet = apiGetTextExtentPoint32(m_hDC, strText, lnglength, stfsize)
With lpRect
'Compute the coords for the text control
.Left = 1
.Top = 1
.Right = m_ImageWidth
.Bottom = m_ImageHeight
' Calculate starting X and Y pos in order to
' center our text within the box.
lpsz = BoundBox(stfsize, lpRect)
If .Right < lpsz.widthX Then .Right = lpsz.widthX
If .Bottom < lpsz.widthY Then .Bottom = lpsz.widthY
End With
' Get ready to Print!
lngRet = apiSetTextColor(m_hDC, m_ForeColor)
lngRet = apiSetBkColor(m_hDC, m_BackColor)
lngRet = SetBkMode(m_hDC, m_BackMode)
' I gave up on SetTextAlign and went with MoveToEx
lngRet = apiSetTextAlign(m_hDC, TA_UPDATECP)
lngRet = apiMoveToEx(m_hDC, lpsz.cx, lpsz.cy, ByVal 0&)
lngRet = apiTextOut(m_hDC, 0, 0, strText, Len(strText))
'Clean up by deleting our created font.
hFont = SelectObject(m_hDC, prevfont)
DeleteObject (hFont)
'Update our Tab Pages ImageData prop
UpdateScreen
'Normal Function Clean up
'Add any other cleanup code here.
'Signal Function return OK
OutputText = True
ExitHere:
'Perform any additional cleanup your code requires
Exit Function
ErrHandler:
'Oh oh, we've been bad..very bad
OutputText = False
Resume ExitHere
End Function
Public Function OutputTextMulti(Optional ByVal strText As String = "") As Boolean
'*******************************************
' Draws multiple Lines of Text.
' Strings must be delimited by the ";" char.
On Error GoTo ErrHandler
'GDI Handles
Dim hFont As Long, prevfont As Long
'To create our Rotated Font
Dim strname As String
Dim FontSize As Long
Dim lnglength As Long
Dim stfsize As SIZEL
Dim lpsz As SizeX2
Dim myfont As LOGFONT
Dim lngTextWidth As Long
Dim X As Long, Y As Long
Dim token As String
' RECT structure
Dim lpRect As RECT
' Clear Image control to background color
Clear
'OK setup font and print into the supplied bitmap
'Escapement = rotation is specified in tenths of a degree
myfont.lfClipPrecision = CLIP_LH_ANGLES
myfont.lfOutPrecision = OUT_TT_ONLY_PRECIS
X = m_RotateDegree
If X > 90 Then X = 90
' Default to 90 degrees if user forgets to set this prop
If X = 0 Then X = 90
myfont.lfEscapement = X * 10
myfont.lfFaceName = m_FontName & Chr$(0) 'Null character at end
'Copy font stuff from Text Control's property sheet
FontSize = m_FontSize
myfont.lfWeight = m_FontWeight
myfont.lfItalic = m_FontItalic
myfont.lfUnderline = m_FontUnderline
'Must be a negative figure for height or system will return
'closest match on character cell not glyph
myfont.lfHeight = (FontSize / 72) * -m_ScreenXdpi
hFont = apiCreateFontIndirect(myfont)
If hFont = 0 Then
Err.Raise vbObjectError + 26, "OutputTextMulti", Err.Description
End If
prevfont = SelectObject(m_hDC, hFont)
' Let's get length and height of non rotated of output string
lnglength = Len(strText)
lngRet = apiGetTextExtentPoint32(m_hDC, strText, lnglength, stfsize)
'With lpRect
'Compute the coords for the text control
' .Left = 1
' .Top = 1
' .Right = m_ImageWidth
' .Bottom = m_ImageHeight
' Calculate starting X and Y pos in order to
' center our text within the box.
' lpsz = BoundBox(stfsize, lpRect)
' If .Right < lpsz.widthX Then .Right = lpsz.widthX
' If .Bottom < lpsz.widthY Then .Bottom = lpsz.widthY
'End With
' Get ready to Print!
lngRet = apiSetTextColor(m_hDC, m_ForeColor)
lngRet = apiSetBkColor(m_hDC, m_BackColor)
lngRet = SetBkMode(m_hDC, m_BackMode)
' I gave up on SetTextAlign and went with MoveToEx
lngRet = apiSetTextAlign(m_hDC, TA_UPDATECP)
' Display the text.
Y = dib_height - 1 - (Abs(myfont.lfHeight)) * sIn(PI_2 - X * PI_180)
'Debug.Print "myfont.lfheight" & myfont.lfHeight
'Debug.Print "Y:" & y
'Debug.Print "m_fontsize" & m_FontSize
'Debug.Print
X = 0
token = Strtok(strText, ";")
Do While token <> ""
lngRet = apiMoveToEx(m_hDC, X, Y, ByVal 0&)
X = X + m_Spacing
' Print this string
lngRet = apiTextOut(m_hDC, 0, 0, token, Len(token))
token = Strtok("", ";")
Loop
'Clean up by deleting our created font.
hFont = SelectObject(m_hDC, prevfont)
DeleteObject (hFont)
'Update our Image control's PictureData prop
UpdateScreen
'Normal Function Clean up
'Add any other cleanup code here.
'Signal Function return OK
OutputTextMulti = True
ExitHere:
'Perform any additional cleanup your code requires
Exit Function
ErrHandler:
'Oh oh, we've been bad..very bad
OutputTextMulti = False
MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
Resume ExitHere
End Function
Private Sub GetScreenDPI()
Dim lngDC As Long
Dim lngPixelsPerInch As Long
Const nTwipsPerInch = 1440
lngDC = GetDC(0)
'Horizontal
m_ScreenXdpi = apiGetDeviceCaps(lngDC, LOGPIXELSX)
'Vertical
m_ScreenYdpi = apiGetDeviceCaps(lngDC, LOGPIXELSY)
lngDC = ReleaseDC(0, lngDC)
End Sub
Private Function BoundBox(ByRef lpsz As SIZEL, ByRef lpRect As RECT) As SizeX2
' *****************************************************
' I would like to thank Rod Stephen's for Permission to
' use his Trig Calculations from his book
' "Custom Controls Library". I also highly reccommend his
' book "Visual Basic Graphics Programming".
' *****************************************************
Dim X(1 To 4) As Single
Dim Y(1 To 4) As Single
Dim xmin As Single
Dim xmax As Single
Dim ymin As Single
Dim ymax As Single
Dim stheta As Single
Dim ctheta As Single
Dim i As Integer
Dim tmp As Single
Dim bbsz As SizeX2
' Calculate a bounding box for the text.
X(1) = 0
X(2) = lpsz.cx
X(3) = X(2)
X(4) = 0
Y(1) = 0
Y(2) = 0
Y(3) = lpsz.cy
Y(4) = Y(3)
' Rotate the bounding box.
stheta = sIn(Abs(m_RotateDegree) * PI_180)
ctheta = Cos(Abs(m_RotateDegree) * PI_180)
For i = 2 To 4
tmp = X(i) * ctheta + Y(i) * stheta
Y(i) = -X(i) * stheta + Y(i) * ctheta
X(i) = tmp
Next i
' Bound the rotated bounding box.
xmin = X(1)
xmax = xmin
ymin = Y(1)
ymax = ymin
For i = 2 To 4
If xmin > X(i) Then xmin = X(i)
If xmax < X(i) Then xmax = X(i)
If ymin > Y(i) Then ymin = Y(i)
If ymax < Y(i) Then ymax = Y(i)
Next i
' Let's set the size our finished Image Control
' to be exactly the size of the Rotated Text
With lpRect
.Top = 0
.Left = 0
' Horizontal Alignment is only LEFT for this version
tmp = .Right / 2 - (xmin + xmax) / 2
For i = 1 To 4
X(i) = tmp + X(i)
Next i
' Vertical Alignment is only Center for this version
tmp = .Bottom / 2 - (ymin + ymax) / 2
For i = 1 To 4
Y(i) = tmp + Y(i)
Next i
End With
bbsz.cx = X(1)
bbsz.cy = Y(1)
bbsz.widthX = (xmax - xmin) + 1
bbsz.widthY = (ymax - ymin) + 1
BoundBox = bbsz
' ******************************
' END OF ROTATED TEXT TRIG CALCS
' ******************************
End Function
Public Sub DrawCircle(LeftX As Long, TopY As Long, diameter As Long, _
Optional TempFillColor As Long = 0)
Dim hNewPen As Long
Dim hOldPen As Long
Dim hNewBrush As Long
Dim hOldBrush As Long
hNewPen = apiCreatePen(PS_SOLID, m_DrawWidth, m_ForeColor)
If TempFillColor <> 0 Then
hNewBrush = apiCreateSolidBrush(TempFillColor)
Else
' Use FillColor Prop
hNewBrush = apiCreateSolidBrush(m_FillColor)
End If
hOldPen = SelectObject(m_hDC, hNewPen)
hOldBrush = SelectObject(m_hDC, hNewBrush)
apiEllipse m_hDC, LeftX, TopY, LeftX + diameter, TopY + diameter
Call SelectObject(m_hDC, hOldPen)
Call DeleteObject(hNewPen)
Call SelectObject(m_hDC, hOldBrush)
Call DeleteObject(hNewBrush)
Me.DIBtoPictureData
End Sub
Public Sub DrawLine(X1 As Long, Y1 As Long, x2 As Long, y2 As Long, _
Optional TempColor As Long = 0)
Dim hNewPen As Long
Dim hOldPen As Long
If TempColor <> 0 Then
hNewPen = apiCreatePen(PS_SOLID, m_DrawWidth, TempColor)
Else
' Use ForeColor Prop
hNewPen = apiCreatePen(PS_SOLID, m_DrawWidth, m_ForeColor)
End If
hOldPen = SelectObject(m_hDC, hNewPen)
Call apiMoveToEx(m_hDC, X1, Y1, ByVal 0&)
LineTo m_hDC, x2, y2
Call SelectObject(m_hDC, hOldPen)
Call DeleteObject(hNewPen)
Me.DIBtoPictureData
End Sub
Public Sub DrawRectangle(X1 As Long, Y1 As Long, x2 As Long, y2 As Long, _
Optional TempFillColor As Long = 0)
Dim hNewBrush As Long
Dim hOldBrush As Long
Dim lngTmpColor As Long
Dim hNewPen As Long
Dim hOldPen As Long
lngTmpColor = apiSetTextColor(m_hDC, TempFillColor)
'm_ForeColor = TempFillColor
If TempFillColor <> 0 Then
hNewBrush = apiCreateSolidBrush(TempFillColor)
Else
' Use FillColor Prop
hNewBrush = apiCreateSolidBrush(m_FillColor)
End If
' Select new brush onto our DC
hOldBrush = SelectObject(m_hDC, hNewBrush)
' Use a NULL Pen so ther is no Border around
' the rectangle
hNewPen = apiCreatePen(PS_NULL, 0&, m_ForeColor)
hOldPen = SelectObject(m_hDC, hNewPen)
Call Rectangle(m_hDC, X1, Y1, x2, y2)
Call SelectObject(m_hDC, hOldBrush)
Call DeleteObject(hNewBrush)
' Cleanup
Call SelectObject(m_hDC, hOldPen)
Call DeleteObject(hNewPen)
'm_ForeColor = lngTmpColor
lngTmpColor = apiSetTextColor(m_hDC, lngTmpColor)
' Update the display
Me.DIBtoPictureData
End Sub
Public Property Let PolygonVertices(pts As Variant)
'ReDim m_Points(UBound(pts) - 1)
'm_Points = pts
End Property
Public Sub DrawPolygon(pts As clsVertices, _
Optional TempFillColor As Long = 0)
Dim hNewBrush As Long
Dim hOldBrush As Long
Dim pt() As POINTAPI
Dim X As Long
On Error GoTo Exit_Err
ReDim pt(pts.NumVertices)
For X = 0 To pts.NumVertices
pt(X).X = pts.VertsX(X)
pt(X).Y = pts.VertsY(X)
Next
If TempFillColor <> 0 Then
hNewBrush = apiCreateSolidBrush(TempFillColor)
Else
' Use FillColor Prop
hNewBrush = apiCreateSolidBrush(m_FillColor)
End If
' Select new brush onto our DC
hOldBrush = SelectObject(m_hDC, hNewBrush)
' Draw the Polygon
Call Polygon(m_hDC, pt(0), pts.NumVertices)
Call SelectObject(m_hDC, hOldBrush)
Call DeleteObject(hNewBrush)
' Update the display
Me.DIBtoPictureData
Exit_OK:
Exit Sub
Exit_Err:
MsgBox Err.Description, vbCritical, "Error Number:" & Err.Number
GoTo Exit_OK:
End Sub
Public Sub DrawPixel(X1 As Long, Y1 As Long, _
Optional TempColor As Long = 0)
'Dim hNewPen As Long
'Dim hOldPen As Long
If TempColor <> 0 Then
'hNewPen = apiCreatePen(PS_SOLID, m_DrawWidth, TempColor)
' Do nothing...use TempColor value directly
Else
' Use ForeColor Prop
' hNewPen = apiCreatePen(PS_SOLID, m_DrawWidth, m_ForeColor)
TempColor = m_ForeColor
End If
'hOldPen = SelectObject(m_hDC, hNewPen)
'Call apiMoveToEx(m_hDC, X1, Y1, ByVal 0&)
'LineTo m_hDC, x2, y2
SetPixel m_hDC, X1, Y1, TempColor
'Call SelectObject(m_hDC, hOldPen)
'Call DeleteObject(hNewPen)
Me.DIBtoPictureData
End Sub
Public Function ShowFontDialog() As Boolean
Dim f As FormFontInfo
' Set some Defaults for the Font Dialog
With f
.Color = m_ForeColor
.Height = m_FontSize '12
.Weight = m_FontWeight
.Italic = m_FontItalic
.UnderLine = m_FontUnderline
.Name = m_FontName '"Arial"
End With
' Call the Font Dialog
blRet = DialogFont(f)
If blRet Then
' Copy users selections over to
' our class vars
With f
m_FontName = .Name
m_FontSize = .Height
m_FontWeight = .Weight
m_FontItalic = .UnderLine
m_FontUnderline = .UnderLine
End With
End If
End Function
' Here are the 3 EVENTS we have sunk from the Image control
Private Sub m_ImageControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
' User started drawing. Next MouseUP we will start drawing from
' the current position of the mouse.
'Debug.Print "MouseDown:" & " X:" & x & " Y:" & y
m_StartDrawing = True
lngRet = apiMoveToEx(m_hDC, TwipsToPixels(CLng(X), Horiz), TwipsToPixels(CLng(Y), Vert), ByVal 0&)
End Sub
Private Sub m_ImageControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
' User stoppped drawing. Next MouseDown we will start drawing from
' the current position of the mouse.
m_StartDrawing = False
End Sub
Private Sub m_ImageControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'Debug.Print "Button:" & Button
'Debug.Print "acleftButton:" & acLeftButton
'Debug.Print "M_MouseDraw:" & m_MouseDraw
Dim tempX As Long, tempY As Long
Dim aPT(0) As POINTAPI
Static PrevX As Single, PrevY As Single
If Button And acLeftButton Then
If m_MouseDraw Then
aPT(0).X = TwipsToPixels(CLng(X), Horiz)
aPT(0).Y = TwipsToPixels(CLng(Y), Vert)
Dim hNewPen As Long
Dim hOldPen As Long
' Use ForeColor Prop
hNewPen = apiCreatePen(PS_SOLID, m_DrawWidth, m_ForeColor)
hOldPen = SelectObject(m_hDC, hNewPen)
' Draw the Line
lngRet = PolylineTo(m_hDC, aPT(0), 1)
' Cleanup
Call SelectObject(m_hDC, hOldPen)
Call DeleteObject(hNewPen)
' Update the screen
Me.DIBtoPictureData
DoEvents
End If
End If
End Sub
' This function is from "Custom Controls Libray"
' written by Rod Stephens and published by
' Wiley Computer Publishing".
' *********************************************
' Return the number of delimiters in the text.
' *********************************************
Private Function NumDelimiters(txt As String, delimiter As String) As Integer
Dim pos As Integer
Dim num As Integer
num = 0
pos = InStr(txt, delimiter)
Do While pos > 0
num = num + 1
pos = InStr(pos + 1, txt, delimiter)
Loop
NumDelimiters = num
End Function
' This function is from "Custom Controls Libray"
' written by Rod Stephens and published by
' Wiley Computer Publishing".
' *********************************************
' Return the next part of str delimited by
' delimiter. Return "" if there's nothing left.
'
' The calling code should pass a non-blank str
' to start breaking apart the pieces of str.
' Pass str = "" to get the next token from the
' original value.
' *********************************************
Private Function Strtok(str As String, delimiter As String) As String
Static txt As String
Dim pos As Integer
If str <> "" Then txt = str
pos = InStr(txt, delimiter)
If pos = 0 Then
Strtok = txt
txt = ""
Else
Strtok = Left$(txt, pos - 1)
txt = Right$(txt, Len(txt) - (pos - 1) - Len(delimiter))
End If
End Function
Private Sub Class_Initialize()
' Init our Screen resolution vars
GetScreenDPI
' Do not set a BackColor
m_BackColor = vbButtonFace ' System button color
m_ForeColor = 255
m_BackMode = TRANSPARENT
m_DrawWidth = 1 '4
m_FontName = "Arial"
m_FontSize = 14
m_FontBold = False
m_FontItalic = False
m_FontUnderline = False
m_FontWeight = 400 ' 700 is Bold
' For rotated text
' Column Spacing in Pixels
m_Spacing = 30
m_RotateDegree = 0
' Scaling factor to 1
m_PicScale = 1
End Sub
Private Sub Class_Terminate()
CleanUp
Set m_ImageControl = Nothing
Set m_ImageForm = Nothing
End Sub
Public Function LoadImageControl(Optional strfName As String = "") As Boolean
' Call the standard File Dialog window to let the
' user select an Image to be loaded in to the Image control.
On Error GoTo Err_fLoadPicture
' Temp Vars
Dim lngRet As Long
Dim blRet As Boolean
' Were we passed the Optional FileName and Path
If Len(strfName & vbNullString) = 0 Then
' Call the File Common Dialog Window
Dim clsDialog As Object
Dim strTemp As String
Set clsDialog = New clsCommonDialog
' Fill in our structure
clsDialog.Filter = "All Files (*.*)" & Chr$(0) & "*.*" & Chr$(0)
clsDialog.Filter = clsDialog.Filter & "JPEG (*.JPG)" & Chr$(0) & "*.JPG" & Chr$(0)
clsDialog.Filter = clsDialog.Filter & "Bmp (*.BMP)" & Chr$(0) & "*.BMP" & Chr$(0)
clsDialog.Filter = clsDialog.Filter & "Gif (*.GIF)" & Chr$(0) & "*.GIF" & Chr$(0)
clsDialog.Filter = clsDialog.Filter & "EMF (*.EMF)" & Chr$(0) & "*.EMF" & Chr$(0)
clsDialog.Filter = clsDialog.Filter & "WMF (*.WMF)" & Chr$(0) & "*.WMF" & Chr$(0)
clsDialog.hdc = 0
clsDialog.MaxFileSize = 256
clsDialog.Max = 256
clsDialog.FileTitle = vbNullString
clsDialog.DialogTitle = "Please Select an Image File to Load"
clsDialog.InitDir = vbNullString
clsDialog.DefaultExt = vbNullString
'clsDialog.hWnd = Application.hWndAccessApp
' Display the File Dialog
clsDialog.ShowOpen
' See if user clicked Cancel or even selected
' the very same file already selected
strfName = clsDialog.FileName
If Len(strfName & vbNullString) = 0 Then
' Raise the exception
Err.Raise vbObjectError + 513, "ClsPictureBox.LoadImageControl", _
"Please Select a Valid Image File"
End If
' If we jumped to here then user supplied a FileName
End If
' It may take a few seconds to render larger JPEGs.
' Set the MousePointer to "HOURGLASS"
Application.Screen.MousePointer = 11
' Load the Picture as a StandardPicture object
m_ImageControl.Picture = strfName
If m_ImageControl.Picture <> strfName Then
Err.Raise vbObjectError + 514, "ClsPictureBox.LoadImageControl", _
"Please Select a Valid Image File"
End If
' Set the Dimensions of the Image Control
' to the actual size of the graphic we are displaying.
' There is a Bug/Feature in how Access handles this
' property. This prop is derived directly from the
' BITMAPINFOHEADER->biXPelsPerMeter & biYPelsPerMeter
' If this value is ZERO in the Bitmap File then an
' Application error occurs and Access fills in the
' Image Controls ImageWidth & Height props with the
' Text from the error.
' The bug is that Access will use whatever values above
' ZERO that are in these members. A lot of Bitmap graphics
' files have garbage or just plain wrong values. This will
' obviously result in incorrect values for these props at
' runtime.
'
' Dim intImageWidth As Long
' Dim intImageHeight As Long
'
' ' Could be invalid props here - quite common
' On Error Resume Next
' intImageWidth = ctl.ImageWidth
' intImageHeight = ctl.ImageHeight
'
' If intImageWidth = 0 Then intImageWidth = ctl.Parent.Width / 2
' If intImageHeight = 0 Then intImageHeight = ctl.Parent.Detail.Height / 2
'
' ' Return to normal error handling
' On Error GoTo Err_fLoadPicture
'
' ' Error check to ensure we do not exceed
' ' SubForm boundaries
' If intImageWidth < ctl.Parent.Width Then
' ctl.Width = intImageWidth
' Else
' ctl.Width = ctl.Parent.Width - 200
' End If
'
' If intImageHeight < ctl.Parent.Detail.Height Then
' ctl.Height = intImageHeight
' Else
' ctl.Height = ctl.Parent.Detail.Height - 200
' End If
'
'
' Create new DC's to match the loaded Images dimensions
' Create DIBSection
blRet = Create(False)
If Not blRet Then
MsgBox "Unable to create DIBSection"
End If
' Copy the contents of the Image control to
' our 2 buffers
SaveImagetoBuffers
' Cleanup
LoadImageControl = True
Exit_LoadPic:
' Set the MousePointer back to Default
Application.Echo True
Application.Screen.MousePointer = 0
Err.Clear
Set clsDialog = Nothing
Exit Function
Err_fLoadPicture:
LoadImageControl = False
MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
Resume Exit_LoadPic
End Function
Function SavetoFile(Optional FName As String = "") As Boolean
'*******************************************
'Purpose: Copies the contents of a standard Access Image Control
' to a disk based Bitmap file.
' My most elaborate error handling scheme yet!
On Error GoTo ErrHandler
'GDI Structures
Dim MyBitmapInfoHeader As BITMAPINFOHEADER
Dim FileHeader As BITMAPFILEHEADER
'Temp variables
Dim lngRet As Long
Dim intReturn As Integer
Dim strPathandFileName As String
Dim strfName As String
Dim Fnum As Integer
' Local storage for the actual bitmap file
Dim varpicture() As Byte
' Length of physical ColorTable
' which is the number of RGBQUADS
' required to hold the required number of colors.
' Only used for Bit Depths less than 16 bits,
Dim lngLenColorTable As Long
' Resize our array to lenght of PictureData prop
ReDim varpicture(LenB(m_ImageControl.PictureData))
' Now copy the PictureData prop to our byte array
varpicture = m_ImageControl.PictureData
' The PictureData property can contain 3 different objects.
'1) CF_ENHMETAFILE. Data that follows is an Enhanced Metafile.
'2) CF_METAFILEPICT. Data that follows is a standard Metafile.
'3) CF_BITMAP. Data is packed Device Independant Bitmap or DIB.
' Now for this example I have only code for the DIB.
' I do have code for the WMF and EMF in the current
' project I am working on. I'll transfer it over some day.
' OK. Let's verify this is a DIB. If not EXIT
' The DIB starts out with the length of the
' BitmapinfoHeader structure which is 40 bytes in length.
If varpicture(0) <> 40 Then
MsgBox "Sorry, you must select a valid Bitmap file", vbOKOnly, "Error: Not a valid Bitmap File"
SavetoFile = False
Exit Function
End If
' We need to copy the BitmapinfoHeader structure embedded in the
' PictureData prop to a local structure so we can easily
' access the structure members.
Call apiCopyMemory(MyBitmapInfoHeader, varpicture(0), Len(MyBitmapInfoHeader))
' Now we can access the BitmapInfoHeader members
With MyBitmapInfoHeader
Select Case .biPlanes * .biBitCount
Case 16, 24, 32
' No ColorTable.
' 16Bit or 24Bit values are encoded directly in RGB QUADS
lngLenColorTable = 0
Case Else
' So this covers anything under 16 bits.
' This means there will be a physical ColorTable.
lngLenColorTable = 4 * (2 ^ (.biPlanes * .biBitCount))
End Select
' All done calculating length of ColorTable
End With
strfName = FName
' Were we passed the Optional FileName and Path
If Len(strfName & vbNullString) = 0 Then
' Call the File Common Dialog Window
Dim clsDialog As Object
Dim strTemp As String
Set clsDialog = New clsCommonDialog
' Fill in our structure
'clsDialog.Filter = "All Files (*.*)" & Chr$(0) & "*.*" & Chr$(0)
'clsDialog.Filter = clsDialog.Filter & "JPEG (*.JPG)" & Chr$(0) & "*.JPG" & Chr$(0)
clsDialog.Filter = clsDialog.Filter & "Bmp (*.BMP)" & Chr$(0) & "*.BMP" & Chr$(0)
clsDialog.hdc = 0
clsDialog.MaxFileSize = 256
clsDialog.Max = 256
clsDialog.FileTitle = vbNullString
clsDialog.DialogTitle = "Please Enter/Select a FileName"
clsDialog.InitDir = vbNullString
clsDialog.DefaultExt = vbNullString
'clsDialog.hWnd = Application.hWndAccessApp
' Display the File Save Dialog
clsDialog.ShowSave
' See if user clicked Cancel or even selected
' the very same file already selected
strfName = clsDialog.FileName
If Len(strfName & vbNullString) = 0 Then
' Raise the exception
Err.Raise vbObjectError + 513, "ClsPictureBox.SavetoFile", _
" No FileName selected...exiting function"
SavetoFile = False
Set clsDialog = Nothing
Exit Function
End If
' If we jumped to here then user supplied a FileName
End If
' Save the Bitmap to a disk file
With FileHeader
.bfType = &H4D42
.bfSize = Len(FileHeader) + (Len(MyBitmapInfoHeader) + lngLenColorTable) + MyBitmapInfoHeader.biSize
.bfOffBits = Len(FileHeader) + (Len(MyBitmapInfoHeader) + lngLenColorTable)
End With
' Get next avail file handle
Fnum = FreeFile
' Have we been passed a FileName?
'If FName = "" Then FName = "C:\PictureBoxContentsToFile.BMP"
' Let's Create/Open our new Bitmap File.
Open strfName For Binary As Fnum
' Write out the Bitmap FileHeader
Put Fnum, , FileHeader
' Write out the BitmapHeader, ColorTable info if any, and Bitmap Data
Put Fnum, , varpicture
' Close the File
Close Fnum
'Signal Function return OK
SavetoFile = True
ExitHere:
'Perform any additional cleanup your code requires
Exit Function
ErrHandler:
'Oh oh, we've been bad..very bad
MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
SavetoFile = False
Set clsDialog = Nothing
Resume ExitHere
End Function
Public Function CaptureScreen(Optional hWnd As Long = 0, Optional ScaleToFit As Boolean = False) As Boolean
' Capture Form by default if not hWnd is supplied
Dim hdc As Long
Dim TempResX As Long
Dim TempResY As Long
Dim FormWidth As Long, FormHeight As Long, z As Long
Dim rc As RECT
' Temp vars
Dim lngDiffRight As Long, lngDiffBottom As Long
' Temp Rectangle structures
Dim rcBoundingBox As RECT
Dim rcOriginalPage As RECT
Dim sngScaleBottom As Single
Dim sngScaleRight As Single
' If we were not passed a hWnd then use the class's Form.
If hWnd = 0 Then hWnd = m_ImageForm.hWnd
' Grab the Screen's DC
hdc = GetDC(0&)
TempResX = apiGetDeviceCaps(hdc, HORZRES)
TempResY = apiGetDeviceCaps(hdc, VERTRES)
' Get the Window dimensions
lngRet = GetWindowRect(hWnd, rc)
' Set our props that are used by the call to CreateDIB
m_ImageWidth = rc.Right - rc.Left
m_ImageHeight = rc.Bottom - rc.Top
' Create DIB with our hWnd's Dimensions
Create True, False
' **************************************
' Leaving scaling code out for now.
' Uncomment if you need it.
' Will add full scaling in next release
' **************************************
'FormWidth = TwipsToPixels(m_ImageForm.WindowWidth, Horiz)
'FormHeight = TwipsToPixels(m_ImageForm.WindowHeight, Vert)
' Maintain aspect ratio
'z = dib_width / dib_height
' Don't base Aspect Ratio on page orientation
' rather base it on the larger dimension/smaller dimension.
'With rcBoundingBox
' .Left = 1
' .Top = 1
' ' Are we in Landscape mode
' .Right = dib_width
' .Bottom = dib_height
'End With
'' Calculate the difference between Right and Bottom
'' to determine which value is larger.
'lngDiffRight = FormWidth - rcBoundingBox.Right
'lngDiffBottom = FormHeight - rcBoundingBox.Bottom
'' Don't allow Zero as a difference. Change it to a value of 1.
'If lngDiffBottom = 0 Then lngDiffBottom = 1
'If lngDiffRight = 0 Then lngDiffRight = 1
'
'
'' Values < 1 indicate we will be scaling Smaller.
'' Values > 1 indicate we will be scaling Larger.
'sngScaleBottom = CSng(rcBoundingBox.Bottom) / Abs(CSng(FormHeight))
'sngScaleRight = CSng(rcBoundingBox.Right) / Abs(CSng(FormWidth))
'
'' We want to use the smaller value as a scale factor.
'' This ensures that our scales page will always fit completely!
' If sngScaleBottom <= sngScaleRight Then
' sngScaleRight = sngScaleBottom
' Else
' sngScaleBottom = sngScaleRight
' End If
'
'' Return rectangle fitted to the Original Report page
'
'
'' Clear our DIB first
''Clear
'
'' Need to add support for Clip, Zoom etc
''lngRet = StretchBlt(m_hDC, 0, 0, FormWidth * sngScaleRight, FormHeight * sngScaleBottom, _
'' hDC, 0&, 0&, TwipsToPixels(m_ImageForm.WindowWidth, Horiz), _
'' TwipsToPixels(m_ImageForm.WindowHeight, Vert), vbSrcCopy)
' Blit the entire Form
lngRet = StretchBlt(m_hDC, 0, 0, dib_width, dib_height, _
hdc, rc.Left, rc.Top, (dib_width), dib_height, vbSrcCopy)
' Update display
Me.DIBtoPictureData
If hWnd = 0 Then
Call ReleaseDC(0&, hdc)
Else
Call ReleaseDC(hWnd, hdc)
End If
End Function
Public Sub PaintPicture()
' Copy from Backup buffer to Image control
' Clear the screen
Clear
' Need to add support for Clip, Zoom etc
lngRet = StretchBlt(m_hDC, 0, 0, dib_width * m_PicScale, dib_height * m_PicScale, _
m_hDC2, 0&, 0&, dib_width, dib_height, vbSrcCopy)
' Update the screen
UpdateScreen
End Sub
Public Sub SaveImagetoBuffers()
' Copy the current contents of the Image control
' to our 2 device contexts.
Dim hdcTemp As Long, hdcMeta As Long
Dim hBMP As Long
Dim hBmpOld As Long
Dim hBmpMeta As Long
Dim ClipType As Long
Dim rc As RECT
Dim hMeta As Long
' Use the Progress Meter
Dim varReturn As Variant
Dim strMsg As String
On Error GoTo ERR_EX
strMsg = "Loading Image..."
varReturn = SysCmd(acSysCmdInitMeter, strMsg, 4)
DoEvents
' Call our function to copy the Image control's
' contents to the ClipBoard.
' If it is not a DIB then it is a METAFILE
If m_ImageControl.PictureData(0) <> 40 Then
' Create the right size DIBSection
hMeta = PictureDataToMetafile()
If hMeta = 0 Then
Err.Raise vbObjectError + 525, "Save Image to Buffers", "Failure to Create Metafile"
End If
' Play the Metafile into our DC
Dim eh As ENHMETAHEADER
lngRet = GetEnhMetaFileHeader(hMeta, Len(eh), eh)
With eh.rclFrame
rc.Right = (((.Right - .Left) / 1000) / 2.54) * m_ScreenXdpi
rc.Bottom = (((.Bottom - .Top) / 1000) / 2.54) * m_ScreenYdpi
m_ImageWidth = rc.Right
m_ImageHeight = rc.Bottom
End With
Create False, False
DoEvents
lngRet = PlayEnhMetaFile(m_hDC, hMeta, rc)
lngRet = DeleteEnhMetaFile(hMeta)
Else
' It's a DIB. Copy the Bits directly
' BUG!!!!
' This version does not support DIBs with ColorTables!!!
' BUG!!!!
Dim bh As BITMAPINFOHEADER
Dim bArray() As Byte
ReDim bArray(LenB(m_ImageControl.PictureData) - 1)
bArray = m_ImageControl.PictureData
apiCopyMemory bh, bArray(0), Len(bh)
m_ImageWidth = bh.biWidth
m_ImageHeight = bh.biHeight
Create False, False
' Copy the BITS directly
apiCopyMemory ByVal m_lPtr, bArray(40), bh.biSizeImage
End If
' Update Progress Bar
varReturn = SysCmd(acSysCmdUpdateMeter, 2)
' Update the Image control's PictureData property
UpdateScreen
' Update Progress Bar
varReturn = SysCmd(acSysCmdUpdateMeter, 5)
Ex_OK:
' Restore Mouse Pointer
Application.Screen.MousePointer = vbNormal
' Clear the Progress meter area
varReturn = SysCmd(acSysCmdRemoveMeter)
varReturn = SysCmd(acSysCmdClearStatus)
Exit Sub
ERR_EX:
MsgBox Err.Description, vbCritical, Err.Source & ":" & Err.Number
GoTo Ex_OK
End Sub
Public Function ReSizeDib(Optional ByVal NewWidth As Long, Optional ByVal NewHeight As Long) As Boolean
Dim bDibFrom() As Byte
Dim bDibTo() As Byte
Dim ctr As Long
Dim m_bmiTemp As BITMAPINFO
Dim m_hdcTemp As Long
Dim hDibTemp As Long
Dim m_lPtrtemp As Long
Dim m_hBmpOldtemp As Long
Dim ds As DIBSECTION
On Error GoTo ERR_EX
' It may take a few seconds to process larger images.
' Set the MousePointer to "HOURGLASS"
Application.Screen.MousePointer = 11
DoEvents
' Check new width and height values
If NewWidth = 0 Then
NewWidth = dib_width * m_PicScale
End If
If NewWidth < 10 Then NewWidth = dib_width
If NewHeight = 0 Then
NewHeight = dib_height * m_PicScale
End If
If NewHeight < 10 Then NewHeight = dib_height
' Create a second DC compatible with the current display
m_hdcTemp = CreateCompatibleDC(0&)
' Minimum 16 bits otherwise a 24 bit DIB created.
With m_bmiTemp.bmiHeader
.biSize = Len(m_bmiTemp.bmiHeader)
.biWidth = NewWidth
.biHeight = NewHeight
.biPlanes = 1
' Always 24 bits
.biBitCount = 24
.biCompression = BI_RGB
.biSizeImage = ((NewWidth * (m_bmiTemp.bmiHeader.biBitCount / 8) + 3) _
And &HFFFFFFFC) * NewHeight
End With
' Create our temp DIBSection
hDibTemp = CreateDIBSection(m_hdcTemp, m_bmiTemp, DIB_RGB_COLORS, m_lPtrtemp, 0, 0)
If hDibTemp = 0 Then
Err.Raise vbObjectError + 52, "ReSizeDIB", "Failure to Create DIBSection"
End If
m_hBmpOldtemp = SelectObject(m_hdcTemp, hDibTemp)
' Time to Resample to our new size
Dim tSAFrom As SAFEARRAY2D
Dim tSATo As SAFEARRAY2D
' Get the bits in the from DIB section:
With tSAFrom
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = dib_height 'm_tBI.bmiHeader.biHeight
.Bounds(1).lLbound = 0
.Bounds(1).cElements = BytesPerScanLine '()
.pvData = m_lPtr
End With
apiCopyMemory ByVal VarPtrArray(bDibFrom()), VarPtr(tSAFrom), 4 ' VarPtrArray(bDibFrom()), VarPtr(tSAFrom), 4
' Get the bits in the to DIB section:
With tSATo
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = NewHeight 'cDibTo.Height
.Bounds(1).lLbound = 0
.Bounds(1).cElements = (NewWidth * (m_bmiTemp.bmiHeader.biBitCount / 8) + 3) _
And &HFFFFFFFC 'cDibTo.BytesPerScanLine()
.pvData = m_lPtrtemp 'cDibTo.DIBSectionBitsPtr
End With
apiCopyMemory ByVal VarPtrArray(bDibTo()), VarPtr(tSATo), 4
' **************************************************************************
' I'm going to implement code to get rid of the SafeArrays in next release.
' **************************************************************************
''If (hdibtempC <> 0) Then
'
' ' m_hBmpOld = SelectObject(m_hDC, m_hDIb)
' ' m_hBmpOld2 = SelectObject(m_hDC2, m_hDib2)
' ' Create = True
''Else
' ' Call DeleteObject(m_hDC)
' ' Call DeleteObject(m_hDC2)
'
'
'' Resize our array to hold Dib bits
' ' Fill in our Temp FROM DIBSECTION structure
' lngRet = apiGetObject(m_hDib2, Len(ds), ds)
' ReDim bDibFrom(ds.dsBm.bmHeight, ds.dsBm.bmWidthBytes) '(ds.dsBmih.biSizeImage)
'
' For ctr = 0 To ds.dsBm.bmHeight - 1
' apiCopyMemory bDibFrom(ctr, 0), ByVal m_lPtr2 + _
' (ctr * ds.dsBm.bmWidthBytes), ds.dsBm.bmWidthBytes ' ds.dsBmih.biSizeImage
' Next ctr
'
' ' Resize our array to hold Dib bits
' ' Fill in our Temp TO DIBSECTION structure
' lngRet = apiGetObject(hDibTemp, Len(ds), ds)
' ReDim bDibTo(ds.dsBm.bmHeight, ds.dsBm.bmWidthBytes) '(ds.dsBmih.biSizeImage)
' 'apiCopyMemory bDibTo(0), ByVal m_lPtrtemp, ds.dsBmih.biSizeImage
' For ctr = 0 To ds.dsBm.bmHeight - 1
' apiCopyMemory bDibTo(ctr, 0), ByVal m_lPtrtemp, ds.dsBm.bmWidthBytes ' ds.dsBmih.biSizeImage
' Next ctr
'
' ************************************************************************************************
' Use the Progress Meter
Dim varReturn As Variant
Dim strMsg As String
strMsg = "Resampling Image..."
varReturn = SysCmd(acSysCmdInitMeter, strMsg, NewHeight)
Dim xScale As Single
Dim yScale As Single
Dim X As Long, Y As Long, xEnd As Long, xOut As Long
Dim fX As Single, fY As Single
Dim ifY As Long, ifX As Long
Dim dX As Single, dy As Single
Dim r As Long, r1 As Single, r2 As Single, r3 As Single, r4 As Single
Dim g As Long, g1 As Single, g2 As Single, g3 As Single, g4 As Single
Dim b As Long, b1 As Single, b2 As Single, b3 As Single, b4 As Single
Dim ir1 As Long, ig1 As Long, ib1 As Long
Dim ir2 As Long, ig2 As Long, ib2 As Long
xScale = (dib_width - 1) / NewWidth 'cDibTo.Width
yScale = (dib_height - 1) / NewHeight 'cDibTo.Height
xEnd = NewWidth - 1 'cDibTo.Width - 1
For Y = 0 To NewHeight - 1 ' cDibTo.Height - 1
fY = Y * yScale
ifY = Int(fY)
dy = fY - ifY
For X = 0 To xEnd
fX = X * xScale
ifX = Int(fX)
dX = fX - ifX
ifX = ifX * 3
' Interpolate using the four nearest pixels in the source
b1 = bDibFrom(ifX, ifY): g1 = bDibFrom(ifX + 1, ifY): r1 = bDibFrom(ifX + 2, ifY)
b2 = bDibFrom(ifX + 3, ifY): g2 = bDibFrom(ifX + 4, ifY): r2 = bDibFrom(ifX + 5, ifY)
b3 = bDibFrom(ifX, ifY + 1): g3 = bDibFrom(ifX + 1, ifY + 1): r3 = bDibFrom(ifX + 2, ifY + 1)
b4 = bDibFrom(ifX + 3, ifY + 1): g4 = bDibFrom(ifX + 4, ifY + 1): r4 = bDibFrom(ifX + 5, ifY + 1)
' Interplate in x direction:
ir1 = r1 * (1 - dy) + r3 * dy: ig1 = g1 * (1 - dy) + g3 * dy: ib1 = b1 * (1 - dy) + b3 * dy
ir2 = r2 * (1 - dy) + r4 * dy: ig2 = g2 * (1 - dy) + g4 * dy: ib2 = b2 * (1 - dy) + b4 * dy
' Interpolate in y:
r = ir1 * (1 - dX) + ir2 * dX: g = ig1 * (1 - dX) + ig2 * dX: b = ib1 * (1 - dX) + ib2 * dX
' Set output:
If (r < 0) Then r = 0
If (r > 255) Then r = 255
If (g < 0) Then g = 0
If (g > 255) Then g = 255
If (b < 0) Then b = 0
If (b > 255) Then
b = 255
End If
xOut = X * 3
bDibTo(xOut, Y) = b
bDibTo(xOut + 1, Y) = g
bDibTo(xOut + 2, Y) = r
Next X
' Update Progress Meter
varReturn = SysCmd(acSysCmdUpdateMeter, Y)
Next Y
' Get DIBSection header
lngRet = apiGetObject(hDibTemp, Len(ds), ds)
Dim varTemp() As Byte
' Allow 40 Bytes for the DIBHeader
ReDim varTemp(ds.dsBmih.biSizeImage + 40)
apiCopyMemory varTemp(40), ByVal m_lPtrtemp, ds.dsBmih.biSizeImage
apiCopyMemory varTemp(0), ds.dsBmih, 40
' Update the PictureData property of the Tab control
m_ImageControl.PictureData = varTemp
'ReDim varTemp(ds.dsBmih.biSizeImage + 40)
' apiCopyMemory varTemp(40), ByVal m_lPtr, ds.dsBmih.biSizeImage
' apiCopyMemory varTemp(0), ds.dsBmih, 40
' Cleanup
Call SelectObject(m_hdcTemp, m_hBmpOldtemp)
Call DeleteObject(hDibTemp)
Call DeleteObject(m_hdcTemp)
apiCopyMemory ByVal VarPtrArray(bDibFrom), 0&, 4
apiCopyMemory ByVal VarPtrArray(bDibTo), 0&, 4
Ex_OK:
' Restore Mouse Pointer
Application.Screen.MousePointer = vbNormal
' Clear the Progress meter area
varReturn = SysCmd(acSysCmdRemoveMeter)
varReturn = SysCmd(acSysCmdClearStatus)
Exit Function
ERR_EX:
MsgBox Err.Description, vbCritical, Err.Source & ":" & Err.Number
GoTo Ex_OK
End Function
Function PictureDataToMetafile() As Long
' Returns handle to Metafile
' DIB's are handled by the calling function by copying the DIB bits
' directly into our DIBSection
' Memory Vars
'Dim bh As Bitmapheader
' Cf_metafilepict structure
Dim cfm As METAFILEPICT
' Handle to a Memory Metafile
Dim hMetafile As Long
' Which ClipBoard format is contained in the PictureData prop
Dim CBFormat As Long
' Byte array to hold the PictureData prop
Dim bArray() As Byte
' Temp var
Dim lngRet As Long
On Error GoTo Err_PtoC
' Resize to hold entire PictureData prop
ReDim bArray(LenB(m_ImageControl.PictureData) - 1)
' Copy to our array
bArray = m_ImageControl.PictureData
' Determine which ClipBoard format we are using
Select Case bArray(0)
'Case 40
' This is a straight DIB.
'ImageType = CF_DIB
Case CF_ENHMETAFILE
' New Enhanced Metafile(EMF)
CBFormat = CF_ENHMETAFILE
' Create a Memory based Metafile we can pass to the ClipBoard
PictureDataToMetafile = SetEnhMetaFileBits(UBound(bArray) + 1 - 8, bArray(8))
'ImageType = CF_ENHMETAFILE
Case CF_METAFILEPICT
' Old Metafile format(WMF)
CBFormat = CF_METAFILEPICT
' Create a Memory based Metafile we can pass to the ClipBoard
' We need to convert from the older WMF to the new EMF format
' Copy the Metafile Header over to our Local Structure
apiCopyMemory cfm, bArray(8), Len(cfm)
' By converting the older WMF to EMF this
' allows us to have a single solution for Metafiles.
' 24 is the number of bytes in the sum of the
' METAFILEPICT structure and the 8 byte ClipBoard Format struct.
PictureDataToMetafile = SetWinMetaFileBits(UBound(bArray) + 24 + 1 - 8, bArray(24), 0&, cfm)
'ImageType = CF_ENHMETAFILE
Case Else
'Should not happen
Err.Raise vbObjectError + 514, "clsPictureBox.fPictureDateToMetafile", _
"Unrecognized PictureData ClipBoard format"
'ImageType = 0
End Select
Exit_PtoC:
Exit Function
Err_PtoC:
PictureDataToMetafile = 0
MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
Resume Exit_PtoC
End Function
Public Function PictureDataToClipBoard() As Boolean
' Copy the contents of the Image control
' to the ClipBoard.
' Memory Vars
Dim hGlobalMemory As Long
Dim lpGlobalMemory As Long
Dim hClipMemory As Long
' Cf_metafilepict structure
Dim cfm As METAFILEPICT
' Handle to a Memory Metafile
Dim hMetafile As Long
' Which ClipBoard format is contained in the PictureData prop
Dim CBFormat As Long
' Byte array to hold the PictureData prop
Dim bArray() As Byte
' Temp var
Dim lngRet As Long
On Error GoTo Err_PtoC
' Resize to hold entire PictureData prop
ReDim bArray(LenB(m_ImageControl.PictureData) - 1)
' Copy to our array
bArray = m_ImageControl.PictureData
' Determine which ClipBoard format we are using
Select Case bArray(0)
Case 40
' This is a straight DIB.
CBFormat = CF_DIB
' MSDN states to Allocate moveable|Shared Global memory
' for ClipBoard operations.
hGlobalMemory = GlobalAlloc(GMEM_MOVEABLE Or GMEM_SHARE Or _
GMEM_ZEROINIT, UBound(bArray) + 1)
If hGlobalMemory = 0 Then _
Err.Raise vbObjectError + 515, "clsPictureBox.PictureDataToClipBoard", _
"GlobalAlloc Failed..not enough memory"
' Lock this block to get a pointer we can use to this memory.
lpGlobalMemory = GlobalLock(hGlobalMemory)
If lpGlobalMemory = 0 Then _
Err.Raise vbObjectError + 516, "clsPictureBox.PictureDataToClipBoard", _
"GlobalLock Failed"
' Copy DIB as is in its entirety
apiCopyMemory ByVal lpGlobalMemory, bArray(0), UBound(bArray) + 1
' Unlock the memory and then copy to the clipboard
If GlobalUnlock(hGlobalMemory) <> 0 Then _
Err.Raise vbObjectError + 517, "clsPictureBox.PictureDataToClipBoard", _
"GlobalUnLock Failed"
Case CF_ENHMETAFILE
' New Enhanced Metafile(EMF)
CBFormat = CF_ENHMETAFILE
hMetafile = SetEnhMetaFileBits(UBound(bArray) + 1 - 8, bArray(8))
Case CF_METAFILEPICT
' Old Metafile format(WMF)
CBFormat = CF_METAFILEPICT
' Copy the Metafile Header over to our Local Structure
apiCopyMemory cfm, bArray(8), Len(cfm)
' Let's convert older WMF to EMF.
' Allows us to have a single solution for Metafiles.
' 24 is the number of bytes in the sum of the
' METAFILEPICT structure and the 8 byte ClipBoard Format struct.
hMetafile = SetWinMetaFileBits(UBound(bArray) + 24 + 1 - 8, bArray(24), 0&, cfm)
Case Else
'Should not happen
Err.Raise vbObjectError + 514, "ImageToClipBoard.modImageToClipBoard", _
"Unrecognized PictureData ClipBoard format"
End Select
' Can we open the ClipBoard.
If OpenClipboard(0&) = 0 Then _
Err.Raise vbObjectError + 518, "ImageToClipBoard.modImageToClipBoard", _
"OpenClipBoard Failed"
' Always empty the ClipBoard First. Not the friendliest thing
' to do if you have several programs interacting!
Call EmptyClipboard
' Now set the Image to the ClipBoard
If CBFormat = CF_ENHMETAFILE Or CBFormat = CF_METAFILEPICT Then
' Remember we can use this logic for both types of Metafiles
' because we converted the older WMF to the newer EMF.
hClipMemory = SetClipboardData(CF_ENHMETAFILE, hMetafile)
Else
' We are dealing with a standard DIB.
hClipMemory = SetClipboardData(CBFormat, hGlobalMemory)
End If
If hClipMemory = 0 Then _
Err.Raise vbObjectError + 519, "ImageToClipBoard.modImageToClipBoard", _
"SetClipBoardData Failed"
' Close the ClipBoard
lngRet = CloseClipboard
If lngRet = 0 Then _
Err.Raise vbObjectError + 520, "ImageToClipBoard.modImageToClipBoard", _
"CloseClipBoard Failed"
' Signal Success!
PictureDataToClipBoard = True
Exit_PtoC:
Exit Function
Err_PtoC:
PictureDataToClipBoard = False
MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
Resume Exit_PtoC
End Function
' ************************************************************
' The code below is not implemented yet...coming for next release
' ************************************************************
'
' Public Function fSaveFile() As Boolean
' ' For System Temp Folder
' ' and temp unique filename
' Const Pathlen = 255
'
' Dim strPath As String * Pathlen
' Dim strFixed As String * Pathlen
' Dim strPathandFileName As String
' Dim FileHeader As BITMAPFILEHEADER
' Dim Fnum As Integer
' Dim hFile As Long
'
' Dim quad(15) As RGBQUAD
'
'
' one:
'
' lngRet = GetDIBColorTable(hdc, 0, 16, quad(0)) ' was 256
'
' ' Get the Systems Temp path
' ' Returns Length of path(num characters in path)
' lngRet = GetTempPath(Pathlen, strPath)
' ' Chop off NULLS and trailing "\"
' strPath = Left(strPath, lngRet) & Chr(0)
'
' ' Now need a unique Filename
' ' locked from a previous aborted attemp.
' strPathandFileName = GetUniqueFilename(strPath, "SLC" & Chr(0), "BMP")
'
' Dim sec As SECURITY_ATTRIBUTES
' Dim lngBytesWritten As Long
' sec.bInheritHandle = True
' sec.lpSecurityDescriptor = 0
' sec.nLength = Len(sec)
'
' hFile = CreateFile(strPathandFileName, GENERIC_WRITE, 0&, sec, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
'
' Dim ds As DIBSECTION
' lngRet = apiGetObject(hBMap, Len(ds), ds)
' Dim x As Long, y As Long, z As Long, BperS As Long
' lngRet = GetDiskFreeSpace("C:\", x, BperS, x, z)
'
'
' With FileHeader
' .bfType = CInt(&H4D42)
' x = Len(FileHeader) + Len(ds.dsBmih) + ds.dsBmih.biSizeImage + 64 '1024
' '.bfSize = Len(FileHeader) + Len(ds.dsBmih) + ds.dsBmih.biSizeImage
' apiCopyMemory FileHeader.bfSize(0), x, 4
' '.bfOffBits = Len(ds.dsBmih) + 8 '+ 14 '(MyBitmapInfo)
' x = Len(ds.dsBmih) + 64 '1024 '+ 14 '(MyBitmapInfo)
' apiCopyMemory FileHeader.bfOffBits(0), x, 4
' End With
'
'
' ' ByVal required if WriteBuffer is a string
' lngRet = WriteFile(hFile, FileHeader, Len(FileHeader), lngBytesWritten, 0)
' ' ByVal required if WriteBuffer is a string
' lngRet = WriteFile(hFile, ds.dsBmih, Len(ds.dsBmih), lngBytesWritten, 0)
' lngRet = WriteFile(hFile, quad(0), 64, lngBytesWritten, 0) '1024
'
'
' '
' x = ds.dsBmih.biSizeImage / BperS
' lngRet = WriteFile(hFile, ByVal ds.dsBm.bmBits, ds.dsBmih.biSizeImage, lngBytesWritten, 0)
' CloseHandle (hFile)
' End Function
'
'Public Function Load(ByVal Name As String) As Boolean
' Dim hBmp As Long
' Dim pName As Long
' Dim aName As String
'
' Load = False
'
' CleanUp
'
' m_hDC = CreateCompatibleDC(0)
' If m_hDC = 0 Then
' Exit Function
' End If
'
' aName = StrConv(Name, vbFromUnicode)
' pName = StrPtr(aName)
'
' hBmp = LoadImage(0, pName, IMAGE_BITMAP, 0, 0, (LR_CREATEDIBSECTION Or LR_LOADFROMFILE))
' If hBmp = 0 Then
' Call DeleteObject(m_hDC)
' m_hDC = 0
' MsgBox "Can't load BMP image"
' Exit Function
' End If
'
' m_bmi.bmiHeader.biSize = Len(m_bmi.bmiHeader)
'
' ' get image sizes
' Call GetDIBits(m_hDC, hBmp, 0, 0, 0, m_bmi, DIB_RGB_COLORS)
'
' ' make 24 bpp dib section
' m_bmi.bmiHeader.biBitCount = 24
' m_bmi.bmiHeader.biCompression = BI_RGB
' m_bmi.bmiHeader.biClrUsed = 0
' m_bmi.bmiHeader.biClrImportant = 0
'
' m_hDIb = CreateDIBSection(m_hDC, m_bmi, DIB_RGB_COLORS, m_lPtr, 0, 0)
' If m_hDIb = 0 Then
' Call DeleteObject(hBmp)
' Call DeleteObject(m_hDC)
' m_hDC = 0
' Exit Function
' End If
'
' m_hBmpOld = SelectObject(m_hDC, m_hDIb)
'
' m_bmi.bmiHeader.biSize = Len(m_bmi.bmiHeader)
'
' ' get image data in 24 bpp format (convert if need)
' Call GetDIBits(m_hDC, hBmp, 0, m_bmi.bmiHeader.biHeight, m_lPtr, m_bmi, DIB_RGB_COLORS)
'
' Call DeleteObject(hBmp)
'
' Load = True
'
'End Function
понедельник, 5 октября 2009 г.
EMF
Подписаться на:
Комментарии к сообщению (Atom)
Комментариев нет:
Отправить комментарий