【发布时间】：2019-12-24 03:05:45
【问题描述】：
我想编写一个小 DMS 来标记和保存 ACAD 文件。为此，我使用 Excel VBA。与 ACAD 2014 / 2015 / 2019 一起使用。
第 1 步 - 保存绘图：
当复制绘图的某些部分时，%temp% 中有一个副本，剪贴板中有一个类似于 WindowsMetaFile (WMF) 的东西。
这里我从 %temp% 获取副本。
第 2 步 - 将文件加载到 ACAD：
通过搜索或过滤，我可以将这些文件作为块加载到 ACAD 中。
通过过滤，列表框显示不同的标签。
我也不想在 Imagebox 中显示 ACAD 文件的缩略图。但它不起作用。
问题：
如何在用户窗体中显示 dwg 的缩略图？
我认为解决方案不止一种。但是我不知道怎么做。
解决方案 1：
在第 1 步中：从剪贴板复制 WMF 并保存到文件。也许是 jpg 或 png?!?
In Step2：从文件中加载图像或WMF并显示在Imagebox中。
解决方案 2：
在第 1 步中：创建 dwg 的缩略图。
在第 2 步：将缩略图加载到 Imagebox。
解决方案 3：
DWG TrueView 控件
https://through-the-interface.typepad.com/through_the_interface/2007/10/au-handouts-t-1.html
需要注册。但只有 Acad 学生版。
解决方案 4：
AutoCAD DwgThumbnail 控件
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 & "\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
【问题讨论】：
标签： excel vba thumbnails autocad dwg