G
GerryE
I am trying to display a thumbnail preview of an AutoCAD drawing inside an
Access form. The code seems to be working and I don't get any errors, the
problem is that it only paints line number 45 when setting the pixels. Can
someone please look at this and help me figure this out?
Option Compare Database
Option Explicit
Public TagCount As Single
Private Const MAX_PATH = 2600
'/// BEGIN API FOR THE BITMAP & PAINT////
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
'The all important Type - RECT
'Contains the coordinates (relative to the Window's DC that we are
'Using)
Private Const WM_PAINT = &HF
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
'These are all of the different styles that can be used as an edge
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_RIGHT Or BF_BOTTOM Or BF_LEFT Or BF_TOP)
'And the constants that define which side of the rectangle to draw
'On, with BF_RECT being all four sides
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hdc As Long) As Long
'This releases the Device Context for the window that we
'Are going to draw on.
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
'Uses the values passed to it to define a rectangular
'Area on the screen.
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 GetDC Lib "user32" _
(ByVal hwnd 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 SetPixel Lib _
"gdi32" (ByVal hdc As Long, ByVal X As _
Long, ByVal Y As Long, ByVal crColor _
As Long) As Long
'///END API FOR BITMAP & PAINT///
'A variable to hold found files from the
'FindFile method
'Private cFiles As Collection
Dim RC As RECT
Public Function PaintPreview(strFile As String) As Integer
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
ReDim bytBMPBuff(udtRec.lngLen)
'Length of the data...
'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
Dim frmActive As Form
''''' Dim ctlActive As Control
''''' Dim hWndParent As Long
'''''
''''' ' Clear the control variable.
''''' 'Set Screen_ActiveSubformControl = Nothing
'''''
''''' ' Assume a subform is not active.
''''' 'Set_Screen_ActiveSubformControl = False
'''''
''''' ' Get the active form and control.
''''' On Error Resume Next
Set frmActive = Screen.ActiveForm
''''' Set ctlActive = Screen.ActiveControl
''''' If Err <> 0 Then Exit Function
'''''
''''' ' Get the unique window handle identifying the form
''''' ' .. the active control is on.
''''' hWndParent = ctlActive.Parent.Properties("hWnd")
''''' 'hWndParent = frmActive.Parent.Properties("hWnd")
'lngHwnd = FindWindow(vbNullString, Me.Caption)
lngHwnd = frmActive.hwnd
'So we can get its Device Context..
lngDc = GetDC(lngHwnd)
'I thought this was a nice touch..
Me.Caption = strFile
'Clean any old paint off..
Me.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 + 25, lngColor
SetPixel lngDc, lngX + 20, lngY + 50, lngColor
'Increment the counter...
lngCnt = lngCnt + 1
Next lngX
Next lngY
'NEW//FRAME
'SetRect RC, 19, 24, udtHeader.biWidth + 23, udtHeader.biHeight
+ 28
SetRect RC, 19, 24, udtHeader.biWidth + 23, udtHeader.biHeight +
28
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 Command0_Click()
Call
PaintPreview("K:\DESIGN\CadSupport\Profiles\Fixtures\WaterSaver\56611-004-S.dwg")
End Sub
Access form. The code seems to be working and I don't get any errors, the
problem is that it only paints line number 45 when setting the pixels. Can
someone please look at this and help me figure this out?
Option Compare Database
Option Explicit
Public TagCount As Single
Private Const MAX_PATH = 2600
'/// BEGIN API FOR THE BITMAP & PAINT////
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
'The all important Type - RECT
'Contains the coordinates (relative to the Window's DC that we are
'Using)
Private Const WM_PAINT = &HF
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
'These are all of the different styles that can be used as an edge
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_RIGHT Or BF_BOTTOM Or BF_LEFT Or BF_TOP)
'And the constants that define which side of the rectangle to draw
'On, with BF_RECT being all four sides
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hdc As Long) As Long
'This releases the Device Context for the window that we
'Are going to draw on.
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
'Uses the values passed to it to define a rectangular
'Area on the screen.
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 GetDC Lib "user32" _
(ByVal hwnd 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 SetPixel Lib _
"gdi32" (ByVal hdc As Long, ByVal X As _
Long, ByVal Y As Long, ByVal crColor _
As Long) As Long
'///END API FOR BITMAP & PAINT///
'A variable to hold found files from the
'FindFile method
'Private cFiles As Collection
Dim RC As RECT
Public Function PaintPreview(strFile As String) As Integer
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
ReDim bytBMPBuff(udtRec.lngLen)
'Length of the data...
'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
Dim frmActive As Form
''''' Dim ctlActive As Control
''''' Dim hWndParent As Long
'''''
''''' ' Clear the control variable.
''''' 'Set Screen_ActiveSubformControl = Nothing
'''''
''''' ' Assume a subform is not active.
''''' 'Set_Screen_ActiveSubformControl = False
'''''
''''' ' Get the active form and control.
''''' On Error Resume Next
Set frmActive = Screen.ActiveForm
''''' Set ctlActive = Screen.ActiveControl
''''' If Err <> 0 Then Exit Function
'''''
''''' ' Get the unique window handle identifying the form
''''' ' .. the active control is on.
''''' hWndParent = ctlActive.Parent.Properties("hWnd")
''''' 'hWndParent = frmActive.Parent.Properties("hWnd")
'lngHwnd = FindWindow(vbNullString, Me.Caption)
lngHwnd = frmActive.hwnd
'So we can get its Device Context..
lngDc = GetDC(lngHwnd)
'I thought this was a nice touch..
Me.Caption = strFile
'Clean any old paint off..
Me.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 + 25, lngColor
SetPixel lngDc, lngX + 20, lngY + 50, lngColor
'Increment the counter...
lngCnt = lngCnt + 1
Next lngX
Next lngY
'NEW//FRAME
'SetRect RC, 19, 24, udtHeader.biWidth + 23, udtHeader.biHeight
+ 28
SetRect RC, 19, 24, udtHeader.biWidth + 23, udtHeader.biHeight +
28
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 Command0_Click()
Call
PaintPreview("K:\DESIGN\CadSupport\Profiles\Fixtures\WaterSaver\56611-004-S.dwg")
End Sub