iCAx开思网

标题: Solidworks 将图纸处理成JPG格式文件的宏程序 [打印本页]

作者: w1011038852 时间: 2019-5-23 19:18
标题: Solidworks 将图纸处理成JPG格式文件的宏程序
可以将工程图文件处理为jpg格式文件，可自动判断及设定横纵向，处理文件位置与所处理的图纸文件路径相同，文件名与所处理的文件名相同。处理其他文件可能会报错，新建的、没有保存过的文件也会报错，仅仅是很初始的代码。共勉。

作者: w1011038852 时间: 2019-5-23 19:20
本帖最后由 w1011038852 于 2019-5-23 19:26 编辑

' ******************************************************************************

'将当前视窗激活的图纸文件处理为JPG格式文件，处理后文件路径与当前处理的文件的路径相同

' ******************************************************************************
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
'————自定义全局变量start————

Dim PD As Boolean
'————自定义全局变量end—————

Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc

Dim COSMOSWORKSObj As Object
Dim CWAddinCallBackObj As Object
Set CWAddinCallBackObj = swApp.GetAddInObject("CosmosWorks.CosmosWorks")
Set COSMOSWORKSObj = CWAddinCallBackObj.COSMOSWORKS                               '连接到SW对象，是宏程序与SOLIDWORKS建立连接的桥梁代码，得到的应用程序作为对象传给swApp，没有这条代码宏程序不能继续运行。
Set TopDoc = swApp.ActiveDoc                                                       '总装对象
TopDocPathSplit = Split(TopDoc.GetPathName, "\")                                  '从全文件名中分割，使用Split函数剔除文件名中的"\"
TopDocName = TopDocPathSplit(UBound(TopDocPathSplit))                            '总装文件名称，使用UBound函数获取TopDocPathSplit数组大小
TopDocName = Left(TopDocName, Len(TopDocName) - 7)                               '总装文件名称（去除扩展名.SLDASM），使用Left函数，Left（a,N）从左起第一位开始取值，向右取N位
TopDocPathOnly = Mid(TopDoc.GetPathName, 1, InStrRev(TopDoc.GetPathName, "\", -1))  '总装的完整目录，使用Mid函数，从文件名字符串第一位开始截取出指定数量的字符，使用InStrRev函数获取"\"在文件名字符串中最后出现的位置，即为Mid函数中指定的数量。
'————自定义变量start————

Dim EXPName  As String '处理出来的文件的扩展名
Dim PTA As Boolean

'————自定义变量end—————
Part.ViewZoomtofit2

EXPName = ".JPG" '扩展名定义

Call Potj '调用判断
Call DirT '调用设定
'MsgBox ("xxx")
longstatus = Part.SaveAs3(TopDocPathOnly & "\" & TopDocName & EXPName, 0, 0) '处理文件

Set StudyManagerObj = Nothing
Set ActiveDocObj = Nothing
Set CWAddinCallBackObj = Nothing
Set COSMOSWORKSObj = Nothing

End Sub

Private Sub Potj() '判断图纸状态
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swSheet As SldWorks.Sheet
Dim vSheetProps As Variant
Dim bRet As Boolean

Dim a, b, c, d, e, f, i, j, K, l, m, n, o, p, q As String
Dim G, H As Single

Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swDraw = swModel
Set swSheet = swDraw.GetCurrentSheet
i = "File = " & swModel.GetPathName '当前文档存储路径，含名称
j = "  Sheet = " & swSheet.GetName '当前图幅配置名称
K = " Template = " & swSheet.GetTemplateName '返回模板路径
' Get current sheet settings
vSheetProps = swSheet.GetProperties

a = "    PaperSize    = " & vSheetProps(0)
b = "    TemplateIn    = " & vSheetProps(1)
c = "    Scale1       = " & vSheetProps(2) '比例1
d = "    scale2       = " & vSheetProps(3) '比例2
f = "    FirstAngle    = " & vSheetProps(4) '第几张
'G = "    Width       = " & vSheetProps(5) '图纸宽度
'H = "    Height       = " & vSheetProps(6) '图纸高度
G = vSheetProps(5) '图纸宽度
H = vSheetProps(6) '图纸高度
e = "//"
'MsgBox (G / H)
If G / H < 1 Then
PD = True
Else
PD = False
End If

'MsgBox (a & e & b & e & c & e & d & e & f & e & G & e & H & e & I & e & j & e & K)
End Sub
Private Sub DirT() '设定图纸处理方向
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Dim COSMOSWORKSObj As Object
Dim CWAddinCallBackObj As Object
Set CWAddinCallBackObj = swApp.GetAddInObject("CosmosWorks.CosmosWorks")
Set COSMOSWORKSObj = CWAddinCallBackObj.COSMOSWORKS
boolstatus = swApp.SetUserPreferenceIntegerValue(swUserPreferenceIntegerValue_e.swEdgesTangentEdgeDisplay, 0)
boolstatus = swApp.SetUserPreferenceIntegerValue(swUserPreferenceIntegerValue_e.swEdgesTangentEdgeDisplay, 1)
boolstatus = swApp.SetUserPreferenceIntegerValue(swUserPreferenceIntegerValue_e.swEdgesTangentEdgeDisplay, 0)
boolstatus = swApp.SetUserPreferenceIntegerValue(swUserPreferenceIntegerValue_e.swEdgesTangentEdgeDisplay, 1)
boolstatus = swApp.SetUserPreferenceIntegerValue(swUserPreferenceIntegerValue_e.swEdgesTangentEdgeDisplay, 1)
boolstatus = swApp.SetUserPreferenceIntegerValue(swUserPreferenceIntegerValue_e.swEdgesTangentEdgeDisplay, 0)
boolstatus = swApp.SetUserPreferenceIntegerValue(swUserPreferenceIntegerValue_e.swEdgesTangentEdgeDisplay, 1)
boolstatus = swApp.SetUserPreferenceIntegerValue(swUserPreferenceIntegerValue_e.swEdgesTangentEdgeDisplay, 0)

If PD = True Then
boolstatus = swApp.SetUserPreferenceIntegerValue(swUserPreferenceIntegerValue_e.swTiffPrintPaperSize, swDwgPaperSizes_e.swDwgPaperA4sizeVertical) '纵向
ElseIf PD = False Then
boolstatus = swApp.SetUserPreferenceIntegerValue(swUserPreferenceIntegerValue_e.swTiffPrintPaperSize, swDwgPaperSizes_e.swDwgPaperA4size) '横向
End If
' Save As
'StudyManagerObj = Nothing
'ActiveDocObj = Nothing
'Set CWAddinCallBackObj = Nothing
'Set COSMOSWORKSObj = Nothing

End Sub

作者: qiminger 时间: 2019-5-24 07:54
谢谢楼主朋友分享好工具，学习。

作者: scattie 时间: 2019-5-24 14:30
不错的资料

欢迎光临 iCAx开思网 (https://www.icax.org/)