我想写一点 DMS 来标记和保存 ACAD 文件。为此，我使用 Excel VBA。与 ACAD 2014/2015/2019 一起使用。
第 1 步 - 保存绘图:
当复制绘图的某些部分时，%temp% 中有一个副本，剪贴板中有一个类似于 WindowsMetaFile (WMF) 的东西。
在这里，我从 %temp% 获取副本。
第 2 步 - 将文件加载到 ACAD:
通过搜索或过滤，我可以将这些文件作为 block 加载到 ACAD 中。
通过过滤，列表框显示不同的标签。
我也不想在 Imagebox 中显示 ACAD 文件的缩略图。但它不起作用。
问题:
如何在用户窗体中显示 dwg 的缩略图？
我认为解决方案不止一种。但是我不知道如何。
解决方案1:
在第 1 步中:从剪贴板复制 WMF 并保存到文件。也许是jpg或png？!？
在步骤 2:从文件中加载图像或 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 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 & "\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
最佳答案
怎么说呢:) 没那么容易。 “In Trough the Interface”是一篇如何生成 block 缩略图的文章。 Thumbnails genration
您也可以尝试从一个 block 中存储 WMF 文件并转换它们 - 楼下的 VBA 示例。但这也不是很好。愚蠢地没有准备好使用 API 通过 VBA 或 .NET 获取所有 block 图像。可能有一些昂贵的 DWG 读取库。但我会将 Kens block 的修改版本包装到 vba 可调用 DLL 中并与她一起行动(有 c# 到 vba 转换器)。根本没有那么容易，但会奏效。顺便提一下。无论如何，这不会那么快。如果尚未生成 block 图像，这将需要时间。以及如何将它们存储在 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
结束子
关于excel - 如何在 excel VBA 用户窗体中显示 dwg 文件的缩略图，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/57547517/