Dear Users,
i checked the macros from Axel Hedman
But the macro's aint doing what i like to see.
I get lots of drawings from our client a we have to put on our own sheet formats for the right data for the factory.
what i like to see in the macro is:
that the current open sheet wil get the new sheetformat "sheet-A3.slddrt" with the same scale and as the curent open sheet.
Thanks for your time.
yes i did.
i also change the sheetmane and location like they sayd.
Gordon, try the macro posted here Macro: Batch Reload-Replace Drawing Sheet Format (sub folders as well)
The macro would update all drawings (single or multiple sheets) in the selected folder. You'll have to change the sheet format path, name and paper size(s) in the macro.
For single active file, try the macro from this post https://forum.solidworks.com/message/432563#comment-432563
You will have to modify the sheet format path and name.
What i doing wrong in this code
"S:\Otab\01 TEMPLATES\" is my directory for the slddrt files
"Otab.slddrt" is the file which i want to get as my new sheet format.
still get a blank drawing
'Batch Drawing Sheet Format Update.swp ------------- 10/10/13
'Description: Macro to change/update Drawing Files Sheet Format for all sheets.
'Pre-Condition: Specify the Sheet format path and Sheet format name in the macro.
' The drawing sheet format name should not be same as exisitng sheet format on drawings.
'Post-Condition: Macro will find all the drawing files in the specified folder/location and
' replace the existing sheet format with the new one. Might delete everything contained
' within the old/exisitng format.
'Folder Browse Codes: http://www.cpearson.com/excel/browsefolder.aspx
'Please back up your data before use and USE AT OWN RISK
' This macro is provided as is. No claims, support, refund, safety net, or
' warranties are expressed or implied. By using this macro and/or its code in
' any way whatsoever, the user and any entities which the user represents,
' agree to hold the authors free of any and all liability. Free distribution
' and use of this code in other free works is welcome. If any portion of
' this code is used in other works, credit to the authors must be placed in
' that work within a user viewable location (e.g., macro header). All other
' forms of distribution (i.e., not free, fee for delivery, etc.) are prohibited
' without the expressed written consent by the authors. Use at your own risk!
' ------------------------------------------------------------------------------
' Written by: Deepak Gupta (http://gupta9665.com/)
' -------------------------------------------------------------------------------
Option Explicit
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260
Function BrowseFolder(Optional Caption As String, _
Optional InitialFolder As String) As String
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
If Not F Is Nothing Then
BrowseFolder = F.Items.Item.Path
End If
End Function
Sub main()
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 vSheetName As Variant
Dim longstatus As Long
Dim longwarnings As Long
Dim nErrors As Long
Dim nWarnings As Long
Dim i As Long
Dim sFileName As String
Dim Path As String
' Change sheet format location here
'Make sure to include \ at the end of the path like show in the given path below
Const sTemplatePath As String = "S:\Otab\01 TEMPLATES\"
' Change Sheet format name here which you to put on the drawing sheet.
Const sTemplateName As String = "Otab.slddrt"
'***************************************
On Error Resume Next
Set swApp = Application.SldWorks
Path = BrowseFolder()
If Path = "" Then
MsgBox "Please select the path and try again"
End
Else
Path = Path & "\"
End If
sFileName = Dir(Path & "*.slddrw")
Do Until sFileName = ""
Set swModel = swApp.OpenDoc6(Path & sFileName, swDocDRAWING, swOpenDocOptions_Silent, "", longstatus, longwarnings)
Set swModel = swApp.ActiveDoc
vSheetName = swModel.GetSheetNames
For i = 0 To UBound(vSheetName)
swModel.ActivateSheet vSheetName(i)
Set swSheet = swModel.GetCurrentSheet
vSheetProps = swSheet.GetProperties
swModel.SetupSheet4 swSheet.GetName, vSheetProps(0), swDwgTemplateCustom, vSheetProps(2), vSheetProps(3), False, sTemplatePath & sTemplateName, 0.297, 0.42, "Default"
swModel.ViewZoomtofit2
Next i
swModel.ActivateSheet vSheetName(0)
swModel.ForceRebuild3 False
swModel.Save3 1, nErrors, nWarnings
swApp.CloseDoc swModel.GetTitle
Set swModel = Nothing
sFileName = Dir
Loop
End Sub
Gordon, can you show me your screen via Team Viewer so that I can debug the issue? If yes then share your Team Viewer details via private message.
i did send you the code
problem solved by using teamviewer and the assistant of the programmer Deepak.
in 5 min the macro was edit and tested.
thanks to Deepak we now save a lot of time
Did you try #Task? Or contact Deepak Gupta ??