VBA,VB6 dwg文件生成略缩图

首先注意dwg的版本必须为2010版本及以下的版本

具体的看头文件的6个字符

具体的对应关系见下表

文件格式	发布日期	文件头标签dwg tag
R12	1992年8月	AC1012
R13	1994年11月	AC1013
R14	1997年4月	AC1014
2000	1999年3月	AC1015
2000	2000年5月	AC1015
2000	2001年6月	AC1015
2004	2003年7月	AC1018
2004	2004年5月	AC1018
2004	2005年3月	AC1018
2007	2006年3月	AC1021
2007	2007年12月	AC1021
2007	2008年5月	AC1021
2010	2009年3月	AC1024
2010	2010年3月	AC1024
2010	2011年3月	AC1024
2013	2012年3月	AC1027
2013	2013年3月	AC1027
2013	2014年3月	AC1027
2013	2015年3月	AC1027
2013	2016年3月	AC1027
2018	2017年3月	AC1032
2018	2018年3月	AC1032
2018	2019年3月	AC1032
2018	2020年3月	AC1032
2018	2021年3月	AC1032

 

查看代码

Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    
Type BITMAPFILEHEADER
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type

查看代码

Public Function GetDwgImage(dwgfileName As String)
    Dim PosSentinel As Integer '文件描述块的位置
    Dim biBitCount As Byte
    Dim TypePreview As Integer '缩略图格式
    Dim PosBMP As Long '缩略图位置
    Dim LenBMP As Long '缩略图大小
    Dim biH As BITMAPFILEHEADER 'BMP文件头，DWG文件中不包含位图文件头，要自行加上去
    Dim BMPInfo() As Byte '包含在DWG文件中的BMP文件体
    Dim a() As Byte
    Set myStream = CreateObject("ADODB.Stream")
    myStream.Type = 1
    myStream.Open
    myStream.LoadFromFile dwgfileName
    myStream.Position = 13 '从第十三字节开始读取
    a = myStream.Read(4)
    Dim f As Long
    CopyMemory f, a(0), 4 '第13到17字节指示缩略图描述块的位置
    myStream.Position = f + 30 '将指针移到缩略图描述块的第31字节
    TypePreview = myStream.Read(1)(0) ' 第31字节为缩略图格式信息，2 为BMP格式，3为WMF格式
    Select Case TypePreview
       Case 1
       Case 2, 3
           a = myStream.Read(4)
           CopyMemory PosBMP, a(0), 4 'DWG文件保存的位图所在位置
           a = myStream.Read(4)
           CopyMemory LenBMP, a(0), 4 'DWG文件保存的位图所在位置
          myStream.Position = PosBMP + 14 '移动指针到位图块
           biBitCount = myStream.Read(1)(0) '缩略图比特深度
          myStream.Position = PosBMP '从位图块开始处读取全部位图内容备用
           BMPInfo = myStream.Read(LenBMP) '不包含文件头的位图信息
          myStream.Close
           With biH '建立位图文件头
              .bfType = &H4D42
              If biBitCount < 9 Then .bfSize = 54 + 4 * (2 ^ biBitCount) + LenBMP Else .bfSize = 54 + LenBMP
              .bfReserved1 = 0 '保留字节
              .bfReserved2 = 0 '保留字节
              .bfOffBits = 14 + &H28 + 1024 '图像数据偏移
           End With
           Dim bmpfilename As String
           bmpfilename = VBA.Replace(dwgfileName, ".dwg", ".bmp")
           Open bmpfilename For Binary As #1
           Put #1, , biH
           Put #1, , BMPInfo
           Close #1
    End Select
End Function