|
|
5#
楼主 |
发表于 2023-5-21 12:38:36
|
只看该作者
经典案例图书
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim FilePath As String
Dim FileTitle As String
Dim swFeatName As String
Dim swFeatType As Integer
Dim NewFilePath As String
Dim dwgName As String
Dim dataAlignment(11) As Double
Dim fso As Object
Dim Rng() As Variant
Dim i As Integer
Sub 钣金零件转平板图DWG()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set fso = CreateObject("Scripting.FileSystemObject")
FilePath = swModel.GetPathName
FileTitle = Mid(FilePath, InStrRev(FilePath, "\") + 1, Len(FilePath) - InStrRev(FilePath, "\") - 7)
FilePath = Left(FilePath, InStrRev(FilePath, "\"))
i = 0
Do While True
swFeatName = swModel.FeatureByPositionReverse(i).Name
swFeatType = swModel.FeatureByPositionReverse(i).GetType
If swFeatType = 22 Then
ReDim Preserve Rng(i)
Rng(i) = swFeatName
Else
Exit Do
End If
i = i + 1
Loop
NewFilePath = FilePath + FileTitle + ".dwg" '定义工程图名
dataAlignment(0) = 0#
dataAlignment(1) = 0#
dataAlignment(2) = 0#
dataAlignment(3) = 0#
dataAlignment(4) = 0#
dataAlignment(5) = 0#
dataAlignment(6) = 0#
dataAlignment(7) = 0#
dataAlignment(8) = 0#
dataAlignment(9) = 0#
dataAlignment(10) = 0#
dataAlignment(11) = 0#
swModel.ExportToDWG2 NewFilePath, FileTitle, 1, False, dataAlignment, False, False, 1, Null '不需要折弯线时，把后面的5改成1
For i = 0 To UBound(Rng)
dwgName = FilePath + Rng(i) + " - " + FileTitle + ".dwg"
If Dir(dwgName) <> "" Then
fso.MoveFile dwgName, FilePath + FileTitle + "-" + Rng(i) + ".dwg"
End If
Next i
End Sub
|
|
[复制链接]
QQ好友和群
QQ空间
腾讯微博
腾讯朋友
收藏
转播
教程|习题|模型|技巧
点赞
拍砖
发表于 2024-12-23 16:27:11
发表于 2023-5-20 16:53:20
鲁公网安备 37028502190335号