How can i show file thumbnails on an Access form

I want to display file thumbnail metdata on an Access form. I found some code for extracting and displaying the data for VB6  at http://www.vbaccelerator.com/home/VB/Code/Libraries/Shell_Projects/Thumbnail_Extraction/article.asp but when I port it into VBA I have problems transferring the picture data to a VBA control. The pcMemDC class from which the picture can be obtained has the property Itype IPicture but when I reference this property in VBA a compile error "Method or data member not found" appear even though the property name appears in a drop-down after I type the . after the class instance name.

A second problem is how to display the picture returned by pcMemDC - in VB6 this can be assigned to a PictureBox control using

Set PictureBox.Picture = c.Picture

Where c is an instance of pcMemDC

The VBA Image control has a picture property but the picture type may not be the same.

Any ideas on how to progress would be much appreciated.
SimonKravisAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

therealmongooseCommented:
Have you referenced the ocx object?
VBA Design Window>Tools>References>COMCTL32.OCX
With regards displaying the image in a control, Stephen Lebans has some stuff on this - picture box class attached - this may help... This was extracted from his project A2KPictureBoxVer35.mdb
 
More info at http://www.lebans.com/pictureboxtogif.htm
and
http://www.lebans.com/imageclass.htm
 


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

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
SimonKravisAuthor Commented:
Thanks for the pointer - it wasn't the answer but it made me look harder and find it. The answer was to use an InkImage control instead of an Image control. This has a Picture property of type IPicture and the c.Picture assigment worked OK
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.