Hi,  I have this macro to save drawings in solidwoks and pdf format at the same time.  I would like to had some features like those:

1:  if the file name is"????-?????-???.slddrw"  save a copy in the parent directory in jpeg format

2:  if #1 is possible:  adjust to "PLEINE PAGE" custom view before saving      (custon view = fit to screen regardless of views that are of the normal page size)

          (create a macro just to fit to screen like in #2 to)

3:  if in the document proprieties, the propriety "dxf" = yes, save the document in  dxf format in the same directory

4:  apply to all drawings open. ( it actualy works only for active document)

I have put a test sheet for you to back check the macro

thanks a lot  ( I know it is a big task)

Option Explicit

Dim swApp As SldWorks.SldWorks
Dim bolResult As Boolean
Dim lngErrors As Long
Dim lngWarnings As Long

Sub main()

Dim swDoc As SldWorks.ModelDoc2
Dim swDocExt As SldWorks.ModelDocExtension
Dim swDrawing As SldWorks.DrawingDoc
Dim strCurDocFullPath As String
Dim strDWGFullPath As String
Dim strPDFFullPath As String
Dim strCurDocPath As String
Dim strCurDocShortName As String
Dim arr_strSheetNames() As String
Dim strCurSheetName As String
Dim strStartupSheet As String
Dim lngSheet As Long
Dim lngExtPos As Long
Dim lngBackSlashPos As Long
Dim IsFileOpenResponse As Boolean

Set swApp = Application.SldWorks

Set swDoc = swApp.ActiveDoc

If swDoc Is Nothing Then
    MsgBox "Vous devez ouvrir une mise en plan avant d'utiliser cette fonction!", vbExclamation
   
    GoTo PROC_EXIT
End If

If swDoc.GetType <> swDocDRAWING Then
    MsgBox "Le document actif n'est pas une mise en plan! Vous devez ouvrir une mise en plan avant d'utiliser cette fonction.", vbExclamation
   
    GoTo PROC_EXIT
End If

Set swDocExt = swDoc.Extension
Set swDrawing = swDoc

strCurDocFullPath = swDoc.GetPathName

If strCurDocFullPath = "" Then
    MsgBox "Le document actif doit être enregistré manuellement au moins une fois avant d'utiliser cette fonction!", vbExclamation
   
    GoTo PROC_EXIT
End If

lngExtPos = InStrRev(strCurDocFullPath, ".")
lngBackSlashPos = InStrRev(strCurDocFullPath, "\\")

strCurDocPath = Left(strCurDocFullPath, lngBackSlashPos - 1)

strCurDocShortName = Mid(strCurDocFullPath, lngBackSlashPos + 1, lngExtPos - lngBackSlashPos - 1)

strStartupSheet = swDrawing.GetCurrentSheet.GetName

arr_strSheetNames = swDrawing.GetSheetNames

bolResult = swDrawing.ActivateSheet(strStartupSheet)

strPDFFullPath = Replace(strCurDocFullPath, ".slddrw", ".PDF", , , vbTextCompare)

If Dir(strPDFFullPath, vbHidden) <> "" Then
  
   IsFileOpenResponse = IsFileOpen(strPDFFullPath)

If IsFileOpenResponse = False Then

bolResult = swDocExt.SaveAs(strPDFFullPath, 0, swSaveAsOptions_Silent, Nothing, lngErrors, lngWarnings)

Else
MsgBox "Erreur: Le PDF existe déjà et il n'a pas pu être écrasé...Veuillez vérifier si le document PDF est actuellement ouvert sur un autre poste en consultation!", vbExclamation
   
End If

Else
bolResult = swDocExt.SaveAs(strPDFFullPath, 0, swSaveAsOptions_Silent, Nothing, lngErrors, lngWarnings)

End If

bolResult = swDoc.Save3(swSaveAsOptions_Silent + swSaveAsOptions_SaveReferenced, lngErrors, lngWarnings)

PROC_EXIT:
End
End Sub

Function IsFileOpen(ByVal strFic As String) As Boolean
    Dim fic As Integer
    On Error Resume Next
  
    fic = FreeFile()
    Open strFic For Input Access Read Lock Read Write As fic
  
    If Err.Number = 0 Then
        IsFileOpen = False
        Close fic
    Else
        IsFileOpen = True
    End If
End Function