How to show thumbnail of a dwg-File in a excel VBA Userform - excel

Question

I want to write a little DMS to tag and save ACAD files. For this i am using Excel VBA. Using with ACAD 2014 / 2015 / 2019.
Step 1 - save drawing:
When copy some parts of the drawing, there is a copy in %temp% and something like a WindowsMetaFile (WMF) in clipboard.
Here i grab the copy from %temp%.
Step 2 - load file to ACAD:
With serching or filtering i can load theese files as block into ACAD.
By filtering, a listbox show the different tags.
Also i wan´t to show a Thumnail of the ACAD file in a Imagebox. But it doesn´t work.
Problem:
How to show thumnail from dwg´s in userform?
I think there is more than one solution. However I do not know how.
Solution 1:
In Step1: Copy WMF from Clipboard and save to file. Maybe as jpg or png?!?
In Step2: Load Image or WMF from File and show in Imagebox.
Solution 2:
In Step 1: Create a Thumbnail of the dwg.
In Step 2: Load Thumbnail to Imagebox.
Solution 3:
DWG TrueView Control
https://through-the-interface.typepad.com/through_the_interface/2007/10/au-handouts-t-1.html
Need a registration. But only have Acad student version.
Solution 4:
AutoCAD DwgThumbnail Control
https://forums.augi.com/showthread.php?42906-DWG-Block-Preview-Image
But there isn´t a "DwgThumbnail.ocx" file
'Step 1 - it works
Private Sub cmdSpeichern_Click()
'Spaltentitel
Dim SpalteID, SpalteBeschreibung, SpalteDatum, SpalteHäufigkeit, SpalteSystemhersteller, SpalteSystem, SpalteElement, SpalteEinbaulage As String
SpalteID = 1
SpalteDatum = 2
SpalteBeschreibung = 3
SpalteHäufigkeit = 4
SpalteSystemhersteller = 5
SpalteSystem = 6
SpalteElement = 7
SpalteEinbaulage = 8
Dim Pfad, teil
Dim Dateiname As String
Dim MostRecentFile As String
Dim MostRecentDate As Date
Dim FileSpec As String
Dim NewestFile As String
Dim lngZeile As Long
Dim WindowsBenutzername As String
WindowsBenutzername = VBA.Environ("UserName")
Pfad = "C:\Users\" & WindowsBenutzername & "\AppData\Local\Temp\"
teil = "A$"
Dateiname = Dir(Pfad & teil & "?????????.DWG")
If Dateiname <> "" Then
MostRecentFile = Dateiname
MostRecentDate = FileDateTime(Pfad & Dateiname)
Do While Dateiname <> ""
If FileDateTime(Pfad & Dateiname) > MostRecentDate Then
MostRecentFile = Dateiname
MostRecentDate = FileDateTime(Pfad & Dateiname)
End If
Dateiname = Dir
Loop
End If
NewestFile = MostRecentFile
'MsgBox NewestFile
'Datei kopieren
Dim myFSO As Object
Dim qFolder As String, tFolder As String
Dim qFile As String
qFile = NewestFile
qFolder = Pfad
tFolder = ThisWorkbook.Path & "\dwg\"
Set myFSO = CreateObject("Scripting.FileSystemObject")
myFSO.copyfile qFolder & qFile, tFolder & qFile, True
'Datei umbenennen
Name tFolder & NewestFile As tFolder & Tabelle2.Cells(1, 2) & ".dwg"
'Infos in Excel einragen
lngZeile = 3
Do Until Tabelle1.Cells(lngZeile, 1) = ""
lngZeile = lngZeile + 1
Loop
If Tabelle1.Cells(lngZeile + 1, 1) = "" Then
Tabelle1.Cells(lngZeile, SpalteID) = Tabelle2.Cells(1, 2)
Tabelle1.Cells(lngZeile, SpalteDatum) = Now ' Format
Tabelle1.Cells(lngZeile, SpalteBeschreibung) = txtBeschreibung.Value
Tabelle1.Cells(lngZeile, SpalteHäufigkeit) = "0"
Tabelle1.Cells(lngZeile, SpalteSystemhersteller) = cboSystemhersteller
Tabelle1.Cells(lngZeile, SpalteSystem) = cboSystem.Value
Tabelle1.Cells(lngZeile, SpalteElement) = cboElement.Value
'Tabelle1.Cells(lngZeile, SpalteEinbaulage) = cboEinbaulage.Value
End If
'ID erhöhen
Tabelle2.Cells(1, 2) = Tabelle2.Cells(1, 2) + 1
'Datei abspeichern
ThisWorkbook.Save
'Fertigmeldung
MsgBox "Zeichnung erfolgreich gespeichert."
End Sub
'Step 2 - It´s not final, but works
Private Sub CommandButton3_Click()
Dim insertionPnt(0 To 2) As Double
inserationPnt = AutoCAD.Application.ActiveDocument.Utility.GetPoint(, "Einfügepunkt wählen: ")
Dim BlockRef As AcadBlockReference
'Runden
inserationPnt(0) = Round(inserationPnt(0), 0)
inserationPnt(1) = Round(inserationPnt(1), 0)
inserationPnt(2) = 0
insertionPnt(0) = inserationPnt(0): insertionPnt(1) = inserationPnt(1): insertionPnt(2) = inserationPnt(2)
FileToInsert = ThisWorkbook.Path & "\dwg\10.dwg"
Set BlockRef = AutoCAD.Application.ActiveDocument.ModelSpace.InsertBlock(insertionPnt, FileToInsert, 1#, 1#, 1#, 0)
End Sub

Answer 1

How to say it nicely :) Doesnt work that easy. "In Trough the Interface" is a article how to generate a block thumbnail. Thumbnails genration
You may also try to store WMF files from a block and convert them - VBA sample downstairs. But thats also not really nice. There is stupidly no ready to use API to fetch all Block images by VBA nor by .NET. There might be some expensive DWG reading libs out. But i would wrap a modified Version of Kens block into a vba callable DLL and act with her (there are c# to vba converters out ). At all nothing that easy but will work. And just to mention. That will not be that fast in any case. If the block images are not already generated this will take time.And how to store them in the excel file ? Might be a idea to put them in a database as a blob and use some database connectors. All at all a nightmare.
Sub BlockPreview(blockname As Variant, imageControlName As Variant, UserForm As UserForm)
'
' Biolight - 2008
' http://biocad.blogspot.com/
' Biolightant(at)gmail.com
'
Dim blockRefObj As AcadBlockReference
Dim insertionPnt(0 To 2) As Double
insertionPnt(0) = -10000000000000#: insertionPnt(1) = -10000000000000#: insertionPnt(2) = 0
' Insert Block
Set blockRefObj = ThisDrawing.modelspace.InsertBlock(insertionPnt, blockname, 1#, 1#, 1#, 0)
Dim minPt As Variant
Dim maxPt As Variant
blockRefObj.GetBoundingBox minPt, maxPt
minPt(0) = minPt(0) - 2
minPt(1) = minPt(1) - 2
maxPt(0) = maxPt(0) + 2
maxPt(1) = maxPt(1) + 2
' Block Zoom
ZoomWindow minPt, maxPt
ThisDrawing.REGEN acActiveViewport
'ThisDrawing.Regen True
' Make SelectionSets
Dim FType(0 To 1) As Integer, FData(0 To 1)
Dim BlockSS As AcadSelectionSet
On Error Resume Next
Set BlockSS = ThisDrawing.SelectionSets("BlockSS")
If ERR Then Set BlockSS = ThisDrawing.SelectionSets.Add("BlockSS")
BlockSS.CLEAR
FType(0) = 0: FData(0) = "INSERT": FType(1) = 2: FData(1) = blockname
BlockSS.Select acSelectionSetAll, , , FType, FData
' Block Export image(wmf)
ThisDrawing.Export ThisDrawing.PATH & "\" & blockname, "wmf", BlockSS
BlockSS.ITEM(0).DELETE
BlockSS.DELETE
ThisDrawing.applicaTION.UPDATE
' ZoomPrevious
applicaTION.ZoomPrevious
' UserForm image control picture = block.wmf
UserForm.CONTROLS(imageControlName).Picture = LoadPicture(ThisDrawing.PATH & "\" & blockname & ".wmf")
UserForm.CONTROLS(imageControlName).PictureAlignment = fmPictureAlignmentCenter
UserForm.CONTROLS(imageControlName).PictureSizeMode = fmPictureSizeModeZoom
' Delete block.wmf file
Dim fs, F, F1, FC, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set F = fs.getfolder(ThisDrawing.PATH)
Set FC = F.FILES
For Each F1 In FC
If F1.NAME = blockname & ".wmf" Then
F1.DELETE
End If
Next
On Error GoTo 0
End Sub