Attribute VB_Name = "modImageFunct"
Option Explicit
Public Type GetImageType
ImageWidth As Long 'Image width in pixels
ImageHeight As Long 'Image height in pixels
ImagePixel() As Long '2-D pixel array containing colors
End Type
Public Type BitmapInfoHeaderType
BiSize As Long 'Size of this structure in bytes
BiWidth As Long 'Bitmap width in pixels
BiHeight As Long 'Bitmap height in pixels
BiPlanes As Integer 'Number of color planes
BiBitCount As Integer 'Number of bytes representing a color
BiCompression As Long 'Type of compression
BiSizeImage As Long 'Size of Bitmap in bytes
BiXPelsPerMeter As Long 'Horz resolution in pixels/meter
BiYPelsPerMeter As Long 'Vert resolution in pixels/meter
BiClrUsed As Long 'Number of color table indexes used
BiClrImportant As Long 'Number of color table indexes needed
End Type
Public Type BitmapInfoType
BmiHeader As BitmapInfoHeaderType 'Bitmap statistics
BmiColors() As Byte 'Pixel color data
End Type
'Get pixel data from a device independant bitmap
' HDC hdc, 'Handle to DC
' HBITMAP hbmp, 'Handle to bitmap
' UINT uStartScan, 'First scan line to get
' UINT cScanLines, 'Number of scan lines to get
' LPVOID lpvBits, 'Array for holding bitmap pixels
' LPBITMAPINFO lpbi, 'Bitmap info structure
' UINT uUsage 'RGB or palette index
Private Declare Function GetDIBits Lib "GDI32.dll" (ByVal hDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BitmapInfoType, ByVal wUsage As Long) As Long
'Create compatible memory device context for specified device
'CreateCompatibleDC, 'Handle to DC
'Private Declare Function Create_DC Lib "gdi32" Alias "CreateCompatibleDC" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleDC Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "GDI32.dll" (ByVal hDC As Long) As Long
Public Sub DirectGetImage(ByVal StdPic As StdPicture, BitMapImageType As GetImageType)
'Dim StdPic As StdPicture 'Image loaded from file
Dim lng_dcHandle As Long 'Handle for compatible device context
Dim ImageWidth As Long 'Image's width in pixels
Dim ImageHeight As Long 'Image's height in pixels
Dim RawImage As BitmapInfoType 'Raw image data from the file
Dim RawImageIdx As Long 'Index into raw pixel data
Dim Mcint_RGB As Long
Dim CurX As Long 'X index
Dim CurY As Long 'Y index
'Load the bitmap from file
'Set StdPic = LoadPicture(BitmapPath)
'Create a DC compatible with this app's current screen
' lng_dcHandle = Create_DC(&H0)
lng_dcHandle = CreateCompatibleDC(&H0)
'StdPicture units are HIMETRIC, convert to pixels
' 1 cm = 567 twip, 1 cm = 1000 HIMETRIC
ImageWidth = StdPic.Width * 0.001 * 567 / Screen.TwipsPerPixelX
ImageHeight = StdPic.Height * 0.001 * 567 / Screen.TwipsPerPixelY
'Prepare the BitmapInfo structure to receive the image data
ReDim RawImage.BmiColors(3, ImageWidth - 1, ImageHeight - 1)
With RawImage.BmiHeader
.BiSize = 40
.BiWidth = ImageWidth
.BiHeight = ImageHeight
.BiPlanes = 1
.BiBitCount = 32
.BiSizeImage = 3 * ImageWidth * ImageHeight
End With
'Get image pixel data
Call GetDIBits(lng_dcHandle, StdPic.Handle, 0, ImageHeight, RawImage.BmiColors(0, 0, 0), RawImage, Mcint_RGB)
'Convert the raw image into a final image
With BitMapImageType
.ImageWidth = RawImage.BmiHeader.BiWidth
.ImageHeight = RawImage.BmiHeader.BiHeight
ReDim .ImagePixel(1 To .ImageWidth, 1 To .ImageHeight)
For CurX = 0 To .ImageWidth - 1
For CurY = 0 To .ImageHeight - 1
'Flip image and exchange blue and red
.ImagePixel(CurX + 1, .ImageHeight - CurY) = RGB( _
RawImage.BmiColors(2, CurX, CurY), _
RawImage.BmiColors(1, CurX, CurY), _
RawImage.BmiColors(0, CurX, CurY))
Next CurY
Next CurX
End With
Call DeleteDC(lng_dcHandle)
End Sub
Sub GetImage(ByVal BitmapPath As String, BitMapImageType As GetImageType)
Dim StdPic As StdPicture 'Image loaded from file
Dim lng_dcHandle As Long 'Handle for compatible device context
Dim ImageWidth As Long 'Image's width in pixels
Dim ImageHeight As Long 'Image's height in pixels
Dim RawImage As BitmapInfoType 'Raw image data from the file
Dim RawImageIdx As Long 'Index into raw pixel data
Dim Mcint_RGB As Long
Dim CurX As Long 'X index
Dim CurY As Long 'Y index
'Load the bitmap from file
Set StdPic = LoadPicture(BitmapPath)
'Create a DC compatible with this app's current screen
' lng_dcHandle = Create_DC(&H0)
lng_dcHandle = CreateCompatibleDC(&H0)
'StdPicture units are HIMETRIC, convert to pixels
' 1 cm = 567 twip, 1 cm = 1000 HIMETRIC
ImageWidth = StdPic.Width * 0.001 * 567 / Screen.TwipsPerPixelX
ImageHeight = StdPic.Height * 0.001 * 567 / Screen.TwipsPerPixelY
'Prepare the BitmapInfo structure to receive the image data
ReDim RawImage.BmiColors(3, ImageWidth - 1, ImageHeight - 1)
With RawImage.BmiHeader
.BiSize = 40
.BiWidth = ImageWidth
.BiHeight = ImageHeight
.BiPlanes = 1
.BiBitCount = 32
.BiSizeImage = 3 * ImageWidth * ImageHeight
End With
'Get image pixel data
Call GetDIBits(lng_dcHandle, StdPic.Handle, 0, ImageHeight, RawImage.BmiColors(0, 0, 0), RawImage, Mcint_RGB)
'Convert the raw image into a final image
With BitMapImageType
.ImageWidth = RawImage.BmiHeader.BiWidth
.ImageHeight = RawImage.BmiHeader.BiHeight
ReDim .ImagePixel(1 To .ImageWidth, 1 To .ImageHeight)
For CurX = 0 To .ImageWidth - 1
For CurY = 0 To .ImageHeight - 1
'Flip image and exchange blue and red
.ImagePixel(CurX + 1, .ImageHeight - CurY) = RGB( _
RawImage.BmiColors(2, CurX, CurY), _
RawImage.BmiColors(1, CurX, CurY), _
RawImage.BmiColors(0, CurX, CurY))
Next CurY
Next CurX
End With
Call DeleteDC(lng_dcHandle)
End Sub
Sub FillImageArr(ByRef ImageIndexFilled As Integer, ImageTypeFilled() As ImageType, KeyFilled As String, PictureFilled As StdPicture)
ImageTypeFilled(ImageIndexFilled).key = KeyFilled
Set ImageTypeFilled(ImageIndexFilled).Picture = PictureFilled
ImageIndexFilled = ImageIndexFilled + 1
End Sub
Function CorrespondImage(CurrentImageType() As ImageType, CurrentKey As String) As StdPicture
Dim k As Integer
For k = 0 To 100
If CurrentImageType(k).key = CurrentKey Then
Set CorrespondImage = CurrentImageType(k).Picture
Exit Function
End If
Next k
If k = 101 Then
Set CorrespondImage = Nothing
End If
End Function
Function ReturnColor(BitMapImageType As GetImageType, CheckImage As Image, CheckX As Single, CheckY As Single) As Long
If CheckX > 0 And CheckX < CheckImage.Width And CheckY > 0 And CheckY < CheckImage.Height Then
ReturnColor = BitMapImageType.ImagePixel(CheckX / Screen.TwipsPerPixelX, CheckY / Screen.TwipsPerPixelY)
Else
ReturnColor = -1
End If
End Function
