如何在 excel VBA 用户窗体中显示 dwg 文件的缩略图

Question

我想写一点DMS来标记和保存ACAD文件。为此，我正在使用Excel VBA。与ACAD 2014/2015/2019一起使用。

步骤1 - 保存绘图：
复制绘图的某些部分时，%temp%中有一个副本，剪贴板中有一个类似于WindowsMetaFile(WMF(的东西。 在这里，我从%temp%中获取副本。

第 2 步 - 将文件加载到 ACAD：
通过 serching 或过滤，我可以将文件作为块加载到 ACAD 中。 通过筛选，列表框显示不同的标记。 我也不想在图像框中显示 ACAD 文件的指甲。但它不起作用。

问题：
如何在用户表单中显示 dwg 的指甲？ 我认为解决方案不止一种。但是我不知道怎么做。

解决方案1：
在步骤1中：从剪贴板复制WMF并保存到文件。也许是jpg或png?!?
在步骤2中：从文件加载图像或WMF并显示在图像框中。

解决方案 2：
在步骤 1：创建 dwg 的缩略图中。
在步骤2：将缩略图加载到图像框中。

解决方案 3：
DWG 真实视图控件
https://through-the-interface.typepad.com/through_the_interface/2007/10/au-handouts-t-1.html
需要注册。但只有阿卡德学生版。

解决方案 4：
AutoCAD Dwg缩略图控件
https://forums.augi.com/showthread.php?42906-DWG-Block-Preview-Image
但是没有"DwgThumbnail.ocx"文件

'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 & "AppDataLocalTemp"
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 & "dwg10.dwg"
Set BlockRef = AutoCAD.Application.ActiveDocument.ModelSpace.InsertBlock(insertionPnt, FileToInsert, 1#, 1#, 1#, 0)
End Sub

Answer 1

如何说得好:)没那么容易。"在界面槽中"是一篇如何生成块缩略图的文章。缩略图生成 您也可以尝试从块中存储 WMF 文件并转换它们 - 楼下的 VBA 示例。但这也不是很好。愚蠢的是，没有现成的API通过VBA或.NET获取所有块图像。可能会有一些昂贵的 DWG 读取库。但是我会将 Kens 块的修改版本包装成 vba 可调用的 DLL 并与她一起行动(有 c# 到 vba 转换器(。根本没有那么容易，但会起作用。仅提一下。无论如何，这都不会那么快。如果尚未生成块映像，这将需要一些时间。以及如何将它们存储在 excel 文件中？将它们作为 blob 放在数据库中并使用一些数据库连接器可能是一个想法。简直就是一场噩梦。

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

结束子