Option Explicit
Private Declare Function GetDC Lib "user32" (ByVal hwnd 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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type IMGREC
bytType As Byte
lngStart As Long
lngLen As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private RC As RECT
Private Const BDR_SUNKENOUTER = &H2
Private Const BF_BOTTOM = &H8
Private Const BF_LEFT = &H1
Private Const BF_RIGHT = &H4
Private Const BF_TOP = &H2
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Public Function PaintPreview(strFile As String) As Integer
imgPreview.Visible = False
Dim lngSeeker As Long
Dim lngImgLoc As Long
Dim bytCnt As Byte
Dim lngFile As Long
Dim lngCurLoc As Long
Dim intCnt As Integer
Dim udtRec As IMGREC
Dim bytBMPBuff() As Byte
Dim udtColors() As RGBQUAD
Dim udtColor As RGBQUAD
Dim lngHwnd As Long
Dim lngDc As Long
Dim lngY As Long
Dim lngX As Long
Dim intRed As Integer
Dim intGreen As Integer
Dim intBlue As Integer
Dim lngColor As Long
Dim lngCnt As Long
Dim udtHeader As BITMAPINFOHEADER
On Error GoTo Err_Control
If Len(Dir(strFile)) > 0 Then
lngFile = FreeFile
Open strFile For Binary As lngFile
Seek lngFile, 14
Get lngFile, , lngImgLoc
Seek lngFile, lngImgLoc + 17
lngCurLoc = Seek(lngFile)
Seek lngFile, lngCurLoc + 4
Get lngFile, , bytCnt
If bytCnt > 1 Then
For intCnt = 1 To bytCnt
Get lngFile, , udtRec
If udtRec.bytType = 2 Then
'All of the code preceding this Line
'Is identical to the code in Part
'Two of Byte By Byte.
'Now we begin the color extraction
'The start value is the BYTE BEFORE
'The BMP Header data (The RGBQUAD
'And BMP Header are contained within
'Another structure), so move the read/
'Write marker to the next byte...
Seek lngFile, udtRec.lngStart + 1
'Pull out the BMP header data...
Get lngFile, , udtHeader
'Resize the Byte buffer to the full
'Length of the data...
ReDim bytBMPBuff(udtRec.lngLen)
'Did you read Randall's article?
If udtHeader.biBitCount = 8 Then
'Resize the array of RGBQuads, I
'Could also have used the biClrUsed
'Value of the udtHeader...
ReDim udtColors(256)
'Grab all of the color values
Get lngFile, , udtColors
'Now we grab the full record by
'Moving the Read/Write marker
'Back to the start of the data.
'Don't worry about all of the data
'We allready grabbed...
'(If you read Randall's article,
'Remember that the data is reverse
'Scan...
Seek lngFile, udtRec.lngStart
'Fill the buffer...
Get lngFile, , bytBMPBuff
'Now grab the Forms Handle
lngHwnd = FindWindow(vbNullString, Me.Caption)
'So we can get its Device Context..
lngDc = GetDC(lngHwnd)
'I thought this was a nice touch..
''' Frame2.Caption = strFile
'Clean any old paint off..
Frame1.Repaint
'Begin Painting
For lngY = 1 To udtHeader.biHeight
For lngX = udtHeader.biWidth To _
1 Step -1
'See, we are reading the data
'From THE END of the buffer...
lngColor = _
bytBMPBuff((UBound(bytBMPBuff) - lngCnt))
'Get the mapped value
udtColor = udtColors(lngColor)
'Break it into Red
intRed = CInt(udtColor.rgbRed)
'Green
intGreen = CInt(udtColor.rgbGreen)
'And Blue
intBlue = CInt(udtColor.rgbBlue)
'Get a color the API will accept
lngColor = RGB(intRed, intGreen, intBlue)
'Paint this Pixel. The + 5 is to
'Give a little offset from the edge
'Of the form.
'But before we do, would you like
'To have Black backgrounds? Easy,
'Swap the map:
'///BLACK BACKGROUND///
If lngColor = vbBlack Then
lngColor = vbWhite
ElseIf lngColor = vbWhite Then
lngColor = vbBlack
End If
'//////////////////////
'If your prefere White (the true Value) Then just remove that..
SetPixel lngDc, lngX + 20, lngY + 30, lngColor
'Increment the counter...
lngCnt = lngCnt + 1
Next lngX
Next lngY
'NEW//FRAME
SetRect RC, 20, 30, udtHeader.biWidth + 20, udtHeader.biHeight + 30
DrawEdge lngDc, RC, BDR_SUNKENOUTER, BF_RECT
End If
Exit For
ElseIf udtRec.bytType = 3 Then
'Its a Meta File!
Exit For
End If
Next intCnt
Else
'Print Message - No Preview
End If
'Close the file
Close lngFile
'Return the value
End If
ReleaseDC lngHwnd, lngDc
'General Error control
Exit_Here:
Exit Function
Err_Control:
Select Case Err.Number
'Add your Case selections here
Case Else
MsgBox Err.Description
Resume Exit_Here
End Select
End Function
Private Sub CommandButton1_Click()
PaintPreview "e:\temp\test.dwg"
End Sub
