SolidWorks机械工程师网——最大的SolidWorks学习平台

标题: 跪求SW工程图转PDF和CAD的宏！！！！！！ [打印本页]

作者: hyqlyy 时间: 2018-12-7 08:17
标题: 跪求SW工程图转PDF和CAD的宏！！！！！！
各位大神，小弟需要SW工程图转PDF和CAD的宏！！！！！！哪位大哥有的麻烦发下本人扣扣邮箱，感谢。766731497@qq.com

作者: hyqlyy 时间: 2018-12-7 08:41
各位大神，走过路过，有这个宏的麻烦发一下，小弟急用！！！

作者: suzhanpeng 时间: 2018-12-7 16:08
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim FilesPath As String
Dim swAA As String

Sub main()
Set swApp = Application.SldWorks                      '建立与SolidWorks的连接
Set Part = swApp.ActiveDoc                            '得到SolidWorks应用程序对象
FilesPath = swApp.ActiveDoc.GetPathName()             '获取当前零件全路径
swAA = Left(FilesPath, Len(FilesPath) - 6)             '去掉图纸后缀“SLDDRW”
swBB = "dwg"                                           '添加CAD后缀“dwg” ，如果存为PDF 就改成“pdf”
longstatus = Part.SaveAs3(swAA & swBB, 0, 0)          '另存为.......
End Sub

作者: suzhanpeng 时间: 2018-12-7 16:28

Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim Filespath As String
Dim swAA As String, swBB As String
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Filespath = swApp.ActiveDoc.GetPathName()
swAA = Left(Filespath, Len(Filespath) - 6)
swBB = "dwg" ‘转换CAD 为 dwg，转换PDF 为 pdf
longstatus = Part.SaveAs3(swAA & swBB, 0, 0)
End Sub

复制代码

作者: hyqlyy 时间: 2018-12-8 08:30

suzhanpeng 发表于 2018-12-7 16:28

试了下，说语句错误，可能我哪里弄错了，不过我找到一个我能用的了：
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim PathStr As String
Dim FName(500) As String, FNum As Long

Sub main()
Dim i As Long
Dim PathStr0 As String, PathStr1 As String
Dim PathStr2 As String, PathStr3 As String, PathStr4 As String, PahtStr5 As String
Dim L As Long, L1 As Long
PathStr = InputBox("请输入需要转的工程图所在位置")
Call Showfilelist(PathStr)
Set swApp = Application.SldWorks

For i = 0 To FNum - 1
PathStr0 = PathStr & "\" & FName(i)
Set Part = swApp.OpenDoc6(PathStr0, 3, 0, "", longstatus, longwarnings)
L = Len(PathStr0)
PathStr1 = Left(PathStr0, L - 7) & ".DWG"
PathStr2 = Left(PathStr0, L - 7) & ".PDF"
longstatus = Part.SaveAs3(PathStr1, 0, 0)
longstatus = Part.SaveAs3(PathStr2, 0, 0)

Set Part = Nothing

L1 = Len(FName(i))
PathStr3 = Left(FName(i), L1 - 7) & " - 图纸1"
PathStr4 = Left(FName(i), L1 - 7) & " - 图纸2"
PathStr5 = Left(FName(i), L1 - 7) & " - 图纸3"

swApp.CloseDoc PathStr3
swApp.CloseDoc PathStr4
swApp.CloseDoc PathStr5
Next i

End Sub

Private Sub Showfilelist(folderspec As String)
Dim fs, f, f1, fc, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.Files
FNum = 0 '清零
For Each f1 In fc
If InStr(f1.Name,"SLDDRW") > 0 Then
FName(FNum) = f1.Name
FNum = FNum + 1
End If
Next
End Sub

另外，附上我找到的图号分离宏：
Dim a As Integer
Dim b As String
Dim m As String
Dim e As String
Dim k As String
Dim t As String
Dim c As String
Dim j As Integer
Dim strmat As String
Dim tempvalue As String
Dim Part As Object
Dim swApp As SldWorks.SldWorks
Dim swModelDoc As SldWorks.ModelDoc2
Dim swConfig As SldWorks.Configuration
Dim CustPropMgr As SldWorks.CustomPropertyManager
Dim swModel As SldWorks.ModelDoc2

Sub main()
Set swApp = Application.SldWorks
Set swModelDoc = swApp.ActiveDoc
Set swConfig = swModelDoc.ConfigurationManager.ActiveConfiguration
Set swModel = swApp.ActiveDoc
Set CustPropMgr = swModel.Extension.CustomPropertyManager(swModel.ConfigurationManager.ActiveConfiguration.Name) '配置特定延伸

'设定变量
c = swApp.ActiveDoc.GetTitle() '零件名
strmat = Chr(34) + Trim("SW-Material" + "@") + c + Chr(34)
a = InStr(c, " ") - 1    '重点：分隔标识符，这里是一个空格，也可换成其他符号

If a > 0 Then
   k = Left(c, a)
   t = Left(LTrim(e), 3)
   If t = "GBT" Then
         e = "GB/T" + Mid(k, 4)
   Else
         e = k
   End If
   b = Mid(c, a + 2)
   t = Right(c, 7)
   If t = ".SLDPRT" Or t = ".SLDASM" Or t = ".sldprt" Or t = ".sldasm" Then
         j = Len(b) - 7 '消除后缀（区分大小写，即含4种）
   Else
         j = Len(b)
   End If
   m = Left(b, j)
End If
'删除栏  CustPropMgr.Delete ("PartName")
CustPropMgr.Delete ("PartName")
CustPropMgr.Delete ("Number")

'新增
CustPropMgr.Add2 "Number", swCustomInfoText, e
CustPropMgr.Add2 "PartName", swCustomInfoText, m
CustPropMgr.Add2 "数量", swCustomInfoText, ""
CustPropMgr.Add2 "Material", swCustomInfoText, strmat
CustPropMgr.Add2 "Weight", swCustomInfoText, ""
CustPropMgr.Add2 "总重", swCustomInfoText, ""
CustPropMgr.Add2 "Description", swCustomInfoText, ""

End Sub

作者: suzhanpeng 时间: 2018-12-8 09:26

Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long
Dim Filespath As String
Dim swAA As String, swBB As String
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Filespath = swApp.ActiveDoc.GetPathName()
swAA = Left(Filespath, Len(Filespath) - 6)
swBB = "dwg"
longstatus = Part.SaveAs3(swAA & swBB, 0, 0)
End Sub

复制代码

该宏需要你在打开工程图的情况下执行，出错可能是我注释的那一句的注释符号错了！去掉就行了！

作者: hyqlyy 时间: 2018-12-10 08:09

suzhanpeng 发表于 2018-12-8 09:26
该宏需要你在打开工程图的情况下执行，出错可能是我注释的那一句的注释符号错了！去掉就行了！

用我发现的那个宏，运行后，复制黏贴目标文件夹路径，可以把目标文件夹内所有工程图转为CAD和PDF。批量转换，而且不用打开工程图。

作者: amyang 时间: 2018-12-10 11:18
很不错，顶一下！

作者: ryouss 时间: 2018-12-10 14:35

hyqlyy 发表于 2018-12-7 08:41
各位大神，走过路过，有这个宏的麻烦发一下，小弟急用！！！

https://www.swbbsc.com/threadcon-33355.html

參考如上 10#

作者: hdgd501 时间: 2018-12-18 21:48
很不错，找到组织了！

作者: gardner 时间: 2019-2-10 19:24
楼主太有才了，膜拜中……

作者: gardner 时间: 2019-2-11 10:15
好好学习，天天向上！

作者: xiaoyu5you 时间: 2019-2-14 09:43
附件传不上去啊！

作者: yni621 时间: 2020-6-9 17:29
好东西，努力学习学习！

作者: 党支部副书记 时间: 2021-11-3 11:33
感谢分享辛苦了

作者: yangbosnihc 时间: 2021-12-30 13:08

suzhanpeng 发表于 2018-12-7 16:28

这是我见过最简单的代码，666

作者: jiahui767 时间: 2023-4-2 19:08

hyqlyy 发表于 2018-12-10 08:09
用我发现的那个宏，运行后，复制黏贴目标文件夹路径，可以把目标文件夹内所有工程图转为CAD和PDF。批量转 ...

很不错，顶一下！
如何同时转出STEP档案呢？可否一起转出3种格式呢？

作者: sunny_8848 时间: 2023-4-3 08:56
多谢分享，下载备用

欢迎光临 SolidWorks机械工程师网——最大的SolidWorks学习平台 (https://www.swbbsc.com/)