Assembly to Part Macro for Solidworks

[Ömür Tokman]

Hello there,
Generates DWG in current view from attached macro assembly file. It works fine for me, I hope someone makes more advanced versions.
Special thanks to @Rob Edwards

basic logic.
Create Part from Assembly
Save to temp folder
Open and save current view as DWG
-SW 2020 sp3-
Replace the temp file path with your own file path.

Code: Select all

Option Explicit

Dim swApp As SldWorks.SldWorks
Dim swPart As SldWorks.PartDoc
Dim sModelName As String
Dim sModelFullPath As String
Dim TempPartName As String
Dim swModel As SldWorks.ModelDoc2
Dim i As String

Sub main()
    Set swApp = Application.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Set swModel = swApp.ActiveDoc
    sModelName = swModel.GetPathName
    sModelFullPath = Left(sModelName, Len(sModelName) - 6) & "dwg"
'    TempPartName = Left(sModelName, Len(sModelName) - 6) & "SLDPRT"
    Dim bs As Boolean
    Dim Errors As Long
    Dim Warnings As Long
    bs = swModel.Extension.SaveAs("C:\Users\Omur\AppData\Local\Temp\tempPart.SLDPRT", swSaveAsVersion_e.swSaveAsCurrentVersion, swSaveAsOptions_e.swSaveAsOptions_Copy, Nothing, Errors, Warnings)
    Dim swPart As SldWorks.PartDoc
    Set swModel = swApp.OpenDoc6("C:\Users\Omur\AppData\Local\Temp\tempPart.SLDPRT", swDocumentTypes_e.swDocPART, swOpenDocOptions_e.swOpenDocOptions_Silent, "", Errors, Warnings)
    Set swPart = swModel
    Dim alignment(11) As Double
    alignment(0) = 0# ' x origin
    alignment(1) = 0# ' y
    alignment(2) = 0# ' z
    alignment(3) = 0# ' x vector
    alignment(4) = 0#
    alignment(5) = 0#
    alignment(6) = 0# ' y vector
    alignment(7) = 0#
    alignment(8) = 0#
    alignment(9) = 0#
    alignment(10) = 0#
    alignment(11) = 0#
    Dim views(0) As String
'     views(0) = "*geçerli" ' tr
     views(0) = "*current" 'eng
     bs = swPart.ExportToDWG2(sModelFullPath, swModel.GetPathName, swExportToDWG_e.swExportToDWG_ExportAnnotationViews, True, alignment, False, False, 0, views)
     swApp.CloseDoc (swModel.GetPathName)
End Sub

[gupta9665]

I was thinking of another route using the drawing. Create a drawing with current view at 1:1 scale and export that drawings as DWG/DXF. Refer codes below.

Option Explicit

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDrawing As SldWorks.DrawingDoc
Dim swSheet As SldWorks.Sheet
Dim swDrawPath As String
Dim nErrors As Long
Dim nWarnings As Long

Sub main()

Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc

swDrawPath = Left(swModel.GetPathName, InStrRev(swModel.GetPathName, ".")) & "DWG"

'Change Template Name and Paper size here
Set swDrawing = swApp.NewDocument("D:\SolidWorks\SOLIDWORKS 2020\templates\Drawing.drwdot", swDwgPaperAsize, 0#, 0#)
Set swSheet = swDrawing.GetCurrentSheet()

'Change desired view name here, replace Current Model View with your desired name.
swDrawing.CreateDrawViewFromModelView swModel.GetPathName, "Current Model View", 0, 0, 0

swSheet.SetScale 1, 1, True, True
swDrawing.ViewZoomtofit2
swDrawing.Extension.SaveAs swDrawPath, swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, nErrors, nWarnings
swApp.CloseDoc swDrawing.GetTitle

End Sub

[Ömür Tokman]

I was thinking of another route using the drawing. Create a drawing with current view at 1:1 scale and export that drawings as DWG/DXF. Refer coes below.

I tried but there is something I can't do.
Can you watch the video? where am i doing wrong.
I tried the views in Turkish and English.

video2.mp4

(1.65 MiB) Downloaded 115 times

[gupta9665]

Did you changed the drawing paper size which is used in the template name?

Another issue could be the view name. Try using *Isometric.

[Ömür Tokman]

Did you changed the drawing paper size which is used in the template name?

Another issue could be the view name. Try using *Isometric.

Thanks
Template 1:1 scale
I tried other view types in Turkish and English, but it didn't work. I feel it is a very simple shortcoming. I will solve it.

[gupta9665]

I mean the paper size in this line

Set swDrawing = swApp.NewDocument("D:\SolidWorks\SOLIDWORKS 2020\templates\Drawing.drwdot", swDwgPaperAsize, 0#, 0#)

[Ömür Tokman]

I mean the paper size in this line

Set swDrawing = swApp.NewDocument("D:\SolidWorks\SOLIDWORKS 2020\templates\Drawing.drwdot", swDwgPaperAsize, 0#, 0#)

Methods I tried but the page is still blank (not getting model view on the page)

Code: Select all

Option Explicit

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDrawing As SldWorks.DrawingDoc
Dim swSheet As SldWorks.Sheet
Dim swDrawPath As String
Dim nErrors As Long
Dim nWarnings As Long

Sub main()

Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc

swDrawPath = Left(swModel.GetPathName, InStrRev(swModel.GetPathName, ".")) & "DWG"

'Change Template Name and Paper size here
'Set swDrawing = swApp.NewDocument("C:\ProgramData\SOLIDWORKS\SOLIDWORKS 2020\templates\A4 YATAY.drwdot", 12, 0#, 0#)
'Set swDrawing = swApp.NewDocument("C:\ProgramData\SOLIDWORKS\SOLIDWORKS 2020\templates\A4 YATAY.drwdot", swDwgPaperAsize, 0#, 0#)
'Set swDrawing = swApp.NewDocument("C:\ProgramData\SolidWorks\SOLIDWORKS 2020\templates\A4 YATAY.drwdot", swDwgPaperA4size, 0#, 0#)
'Set swDrawing = swApp.NewDocument("C:\ProgramData\SolidWorks\SOLIDWORKS 2020\templates\A4 YATAY.drwdot", 12, 0.297, 0.21)
'Set swDrawing = swApp.NewDocument("C:\ProgramData\SolidWorks\SOLIDWORKS 2020\templates\A4 YATAY.drwdot", 12, 1, 1)
Set swDrawing = swApp.NewDocument("C:\ProgramData\SolidWorks\SOLIDWORKS 2020\templates\Teknik Resim.drwdot", 12, 1, 1)
Set swSheet = swDrawing.GetCurrentSheet()

'Change desired view name here, replace Current Model View with your desired name.
swDrawing.CreateDrawViewFromModelView swModel.GetPathName, "İzometrik", 0, 0, 0

swSheet.SetScale 1, 1, True, True
swDrawing.ViewZoomtofit2
swDrawing.Extension.SaveAs swDrawPath, swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, nErrors, nWarnings
swApp.CloseDoc swDrawing.GetTitle

End Sub

[gupta9665]

Try the below line:

Set swDrawing = swApp.NewDocument("C:\ProgramData\SolidWorks\SOLIDWORKS 2020\templates\Teknik Resim.drwdot", 12, 0#, 0#)
Set swSheet = swDrawing.GetCurrentSheet()

'Change desired view name here, replace Current Model View with your desired name.
swDrawing.CreateDrawViewFromModelView swModel.GetPathName, "*İzometrik", 0, 0, 0

[Ömür Tokman]

Try the below line:

Yes, it works fine with the attached shape.
Thank you again.

Code: Select all

Option Explicit

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDrawing As SldWorks.DrawingDoc
Dim swSheet As SldWorks.Sheet
Dim swDrawPath As String
Dim nErrors As Long
Dim nWarnings As Long

Sub main()

Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc

swDrawPath = Left(swModel.GetPathName, InStrRev(swModel.GetPathName, ".")) & "DWG"

'Replace the temp address below with your own address.
Set swDrawing = swApp.NewDocument("C:\ProgramData\SolidWorks\SOLIDWORKS 2020\templates\Teknik Resim.drwdot", 12, 0#, 0#)
Set swSheet = swDrawing.GetCurrentSheet()

'Change desired view name here, replace Current Model View with your desired name.
swDrawing.CreateDrawViewFromModelView swModel.GetPathName, "*İzometrik", 0, 0, 0

swSheet.SetScale 1, 1, True, True
swDrawing.ViewZoomtofit2
swDrawing.Extension.SaveAs swDrawPath, swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, nErrors, nWarnings
swApp.CloseDoc swDrawing.GetTitle

End Sub