时间戳

首页 > 解决方案 > 如何在 excel VBA 用户窗体中显示 dwg 文件的缩略图

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

问题描述

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

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

第 2 步 - 将文件加载到 ACAD：
通过搜索或过滤，我可以将这些文件作为块加载到 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 DwgThumbnail Control
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

标签： excelvbathumbnailsautocaddwg

解决方案

怎么说呢:) 没那么容易。“In Trough the Interface”是一篇如何生成块缩略图的文章。缩略图生成 您也可以尝试从一个块中存储 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

结束子

推荐阅读