Hallo Michael,
ich kenne mich leider mit Access nicht aus.
Ich hatte aber mal für AutoCAD, also auch VBA, den Viewer erstellen können. Aber es gibt aber auch eine andere Methode, wenn Du nur ein kleines Fenster als Vorschau haben möchtest:
in VB6:
'/// 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_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
'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
Dim RC As RECT
'///END API FOR BITMAP & PAINT///
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 'keine Vorschau wenn der Wert <= 1 ist
For intCnt = 1 To bytCnt
Get lngFile, , udtRec
If udtRec.bytType = 2 Then
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..
Me.Caption = strFile
'Clean any old paint off..
'Label1.Visible = False
Me.Refresh '.AutoRedraw '.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 + 600, lngY + 10, _
lngColor ' position des Bildes
'Increment the counter...
lngCnt = lngCnt + 1
Next lngX
Next lngY
'NEW//FRAME
SetRect RC, 599, 9, udtHeader.biWidth + 601, udtHeader.biHeight + 11 'rahmen
DrawEdge lngDc, RC, BDR_SUNKENOUTER, BF_RECT
'Call getfileinfo
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
Dann noch z.B. hinter einen Button hinterlegt:
Call PaintPreview("C:\temp\123.dwg")
Aber möchtest Du doch den EDrawing benutzen:
1.) muß dieser Viewer bei Dir auf dem rechner installiert sein und auf alle anderen Rechner, wo Dein programm laufen soll.
2.) In VB muß das Steuerelement Edrawing "EModelView 2008 Type Library" eingefügt werden.
( Hier kommt es nun an, welche DWG Zeichnungen Du dir zeigen lassen möchstet. z.B. für AutoCAD2008 brauchst Du den Edrawing 2008!!
3.) Defnieren, welche Zeichnung angezeigt werden soll:
frmVorschauDWG.eview.OpenDoc frm01.lblPfad.Caption & "\" & frm01.lblText1.Caption, 0, 0, 0, ""
Ich hoffe, dass ich Dir weiterhelfen konnte.
Diese Lösung ist aber in CAD.de sehr ausführlich beschrieben ; )
------------------
Schöne Grüße
Feyza : )
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP
Foren auf CAD.de
| 
