当前位置：首页>Excel>SolidWorks*Excel+VBA-BOM加个插图,吧

SolidWorks*Excel+VBA-BOM加个插图,吧

2026-07-21 12:03:02

不知何时起，BOM也开始卷了起来，部件都带上了缩略图，便于识别。

但是吧，Solidworks获取的预览图空白部分太多，就像这样，占地方，实际内容部分大小也就1/3左右，图片调小了根本看不清，更何况表格清单内把图片所在单元格调太大也不合适。

所以，这图得裁掉一部分，这个用Excel的VBA方法就可实现。

Set shp = .Shapes.AddPicture(mypic, msoFalse, msoTrue, InsRng.Left, InsRng.Top, -1, -1)shpnum = .Shapes.Count '所有形状的数量shp.PictureFormat.CropLeft = (shp.Width - shp.Height) / 2'裁剪左边shp.PictureFormat.CropRight = (shp.Width - shp.Height) / 2'裁剪右边shp.CopyPicture: shp.Delete: .Paste'复制图像部分，删除原图，然后再粘贴Set shp = .Shapes.Item(shpnum)'重新获取粘贴后的图像'之所以搞这么复杂，就是为了彻底去掉裁剪的部分

图像，按钮，图表，形状这些元素在Excel的VBA对象中都属于shape类。

主体程序大概就这样

Sub InsPreviewPic() 'BOM插入预览图Dim swModel As String, SwMacro As String, regkey As String, i As LongDim shp As Shape, picH As Long, picW As Long, shpnum As LongDim cH As Long, cW As Long, scal As Double, j As Integer, InsRng As RangeDim mypic As String, pictmp As String    i = 3: SetGolDic    With ThisWorkbook.ActiveSheet        Call DelPreviewPic        SwMacro = ThisWorkbook.Path & "\GetPreViewA.swp"        regkey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application.Version & "\Excel\Options\SwModel"        If swApp Is Nothing Then Set swApp = GetObject(, "SldWorks.Application")        Do While .Cells(i, PropTitDicA("文件全名")) <> ""            mypic = ThisWorkbook.Path & "\PreView.jpg"            If Dir(mypic) <> "" Then Kill mypic            swModel = .Cells(i, PropTitDicA("文件全名"))            myregedit regkey, swModel, "REG_SZ", "W"            swApp.RunMacro SwMacro, "GetPreViewA1", "GetPictures"            If Dir(mypic) <> "" Then                .Rows(i).RowHeight = 90                Set InsRng = .Cells(i, PropTitDicA("预览图"))                Application.StatusBar = "正在插入图片:" & .Cells(i, PropTitDicA("文件全名"))                cH = InsRng.Height: cW = InsRng.Width                Set shp = .Shapes.AddPicture(mypic, msoFalse, msoTrue, InsRng.Left, InsRng.Top, -1, -1)                shpnum = .Shapes.Count                shp.PictureFormat.CropLeft = (shp.Width - shp.Height) / 2                shp.PictureFormat.CropRight = (shp.Width - shp.Height) / 2                shp.CopyPicture: shp.Delete: .Paste                Set shp = .Shapes.Item(shpnum)                With shp                    .LockAspectRatio = msoTrue                    picH = .Height: picW = .Width                    If ((cH - 4) / picH) < ((cW - 4) / picW) Then                        scal = (cH - 4) / picH                    Else                        scal = (cW - 4) / picW                    End If                    .Height = .Height * scal                    .Top = InsRng.Top + (cH - .Height) / 2: .Left = InsRng.Left + (cW - .Width) / 2                End With            End If            i = i + 1        Loop    End With    Application.StatusBar = False    Set swApp = Nothing    MsgBox "模型预览图插入完毕!", vbInformation, "不正经的机械仙人"End SubSub DelPreviewPic() '清除BOM预览图Dim shp As Shape, i As Long    With ThisWorkbook.ActiveSheet        SetGolDic        For Each shp In .Shapes            If shp.Type = msoPicture Then shp.Delete        Next        i = 3        Do While .Cells(i, PropTitDicA("文件全名")) <> ""            .Rows(i).RowHeight = 22            i = i + 1        Loop    End WithEnd Sub