求大神帮合并下宏，改为在工程图下一键STEP，PDF，DWG

dyb9166 · 发表于 2023-4-28 14:50:38

经典图书

零件状态下一键step格式
' ******************************************************************************
' C:\Users\Administrator\AppData\Local\Temp\swx4244\Macro1.swb - macro recorded on 08/08/19 by Tony
' ******************************************************************************
Dim swApp As Object
Dim Part As Object
Dim Filename As String
Dim No As Integer
Dim Title As String
Sub main()

Set objShell = CreateObject("Shell.Application")
      Set objFolder = objShell.BrowseForFolder(0, "请选择文件夹", 201, 17)

      If objFolder Is Nothing Then

         MsgBox "请选择一个有效路径!!"

      ElseIf Dir(objFolder.self.Path, 16) = "" Then

         MsgBox "请选择一个有效路径!!"
         Debug.Print objFolder.self.Path

      Else

         Path = objFolder.self.Path
         Set objFolder = Nothing
         Set objShell = Nothing

      End If


Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
On Error Resume Next
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc

Filename = Part.GetTitle()
'Filename = Left(Filename, Len(Filename) - 1)

'Filename = Left(Filename, InStrRev(Filename, "-") - 2)
Filename = Path & "\" & Filename
'FileName = path & FileName

Debug.Print ("fileName: " & Filename)

sUserDir = VBA.Environ("USERPROFILE") & Chr(92) & Chr(-10304) & Chr(-15386) & Chr(92)

Randomize

If Filename = "" Then Filename = sUserDir & "Part" & Int(Rnd * 1000) & ".SLDDRW"

''' if need SLDDRW FILE,THEN DELETE THIS MARK!

' Part.SaveAs2 Filename, 0, 0, 0

No = Len(Filename)

'dwgFileName = Left(FileName, No - 7) & ".PDF"
dwgFileName = Filename & "STEP"

Part.SaveAs2 dwgFileName, 0, 1, 0

Title = Part.GetTitle

Set Part = swApp.ActiveDoc
'
X = MsgBox(" 已转换完成", 0)
End Sub

工程图下，一键PDF，DWG
' ******************************************************************************
' C:\Users\Administrator\AppData\Local\Temp\swx4244\Macro1.swb - macro recorded on 08/08/19 by Tony
' ******************************************************************************
Dim swApp As Object
Dim Part As Object
Dim Filename As String
Dim No As Integer
Dim Title As String
Sub main()

Set objShell = CreateObject("Shell.Application")
      Set objFolder = objShell.BrowseForFolder(0, "请选择文件夹", 201, 17)

      If objFolder Is Nothing Then

         MsgBox "请选择一个有效路径!!"

      ElseIf Dir(objFolder.self.Path, 16) = "" Then

         MsgBox "请选择一个有效路径!!"
         Debug.Print objFolder.self.Path

      Else

         Path = objFolder.self.Path
         Set objFolder = Nothing
         Set objShell = Nothing

      End If


Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
On Error Resume Next
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc

Filename = Part.GetTitle()
'Filename = Left(Filename, Len(Filename) - 1)

'Filename = Left(Filename, InStrRev(Filename, "-") - 2)
Filename = Path & "\" & Filename
'FileName = path & FileName

Debug.Print ("fileName: " & Filename)

sUserDir = VBA.Environ("USERPROFILE") & Chr(92) & Chr(-10304) & Chr(-15386) & Chr(92)

Randomize

If Filename = "" Then Filename = sUserDir & "Part" & Int(Rnd * 1000) & ".SLDDRW"

''' if need SLDDRW FILE,THEN DELETE THIS MARK!

' Part.SaveAs2 Filename, 0, 0, 0

No = Len(Filename)

'dwgFileName = Left(FileName, No - 7) & ".PDF"
dwgFileName = Filename & "STEP"

Part.SaveAs2 dwgFileName, 0, 1, 0

Title = Part.GetTitle

Set Part = swApp.ActiveDoc
'
X = MsgBox(" 已转换完成", 0)
End Sub