كود vba : حفظ باسم صيغة PDF فقط

[أبو إسحاق]

السلام عليكم

لإنعدام خبرتي في الأكواد ... أطلب مساعدة في التعديل على هذا الكود

معي الكود التالي:

حيث هذا الكود يلغي قائمة صيّغ الحفظ المختلفه في نافذة "حفظ باسم"

ويعطي خيارين "للحفظ بإسم" فقط هما xlsm و xls

Excel Macro-Enabled Workbook (*.xlsm)

Excel 97-2003 Workbook (*.xls)

 

أنا أريد ألغي الخيارين أعلاه أيضا  وأستبدالهم بالحفظ إلى PDF فقط لا غير

هذا هو الكود

Private Sub CustomSave(Optional SaveAs As Boolean)

    'Declare the variables
    Dim ActiveSht As Object
    Dim FileFormat As Variant
    Dim FileName As String
    Dim FileFilter As String
    Dim FilterIndex As Integer
    Dim Msg As String
    Dim Ans As Integer
    Dim OrigSaved As Boolean
    Dim WorkbookSaved As Boolean
    
    'Turn off screen updating
    Application.ScreenUpdating = False
    
    'Turn off events so that the BeforeSave event doesn't occur
    Application.EnableEvents = False
    
    'Assign the status of the workbook's Saved property to a variable
    OrigSaved = Me.Saved
    
    'Assign the active sheet to an object variable
    Set ActiveSht = ActiveSheet
    
    'Call the HideAllSheets routine
    Call HideAllSheets
    
    'Save workbook or prompt for SaveAs filename
    If SaveAs Or Len(Me.Path) = 0 Then
        If Val(Application.Version) < 12 Then
            FileFilter = "Microsoft Office Excel Workbook (*.xls), *.xls"
            FilterIndex = 1
        Else
            FileFilter = "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm, " & _
                "Excel 97-2003 Workbook (*.xls), *.xls"
            If Right(Me.Name, 4) = ".xls" Then
                FilterIndex = 2
            Else
                FilterIndex = 1
            End If
        End If
        Do
            FileName = Application.GetSaveAsFilename( _
                InitialFileName:=Me.Name, _
                FileFilter:=FileFilter, _
                FilterIndex:=FilterIndex, _
                Title:="SaveAs")
            If FileName = "False" Then Exit Do
            If IsLegalFilename(FileName) = False Then
                Msg = "The file name is invalid.  Try one of the "
                Msg = Msg & "following:" & vbCrLf & vbCrLf
                Msg = Msg & Chr(149) & " Make sure that the file name "
                Msg = Msg & "does not contain any" & vbCrLf
                Msg = Msg & "   of the following characters:  "
                Msg = Msg & "< > ? [ ] : | or *" & vbCrLf
                Msg = Msg & Chr(149) & " Make sure that the file/path "
                Msg = Msg & "name does not exceed" & vbCrLf
                Msg = Msg & "   more than 218 characters."
                MsgBox Msg, vbExclamation, "Invalid File Name"
            Else
                If Val(Application.Version) < 12 Then
                    FileFormat = -4143
                Else
                    If Right(FileName, 4) = ".xls" Then
                        FileFormat = 56
                    Else
                        FileFormat = 52
                    End If
                End If
                If Len(Dir(FileName)) = 0 Then
                    Application.DisplayAlerts = False
                    Me.SaveAs FileName, FileFormat
                    Application.DisplayAlerts = True
                    WorkbookSaved = True
                Else
                    Ans = MsgBox("'" & FileName & "' already exists.  " & _
                        "Do you want to replace it?", vbQuestion + vbYesNo, _
                        "Confirm Save As")
                    If Ans = vbYes Then
                        Application.DisplayAlerts = False
                        Me.SaveAs FileName, FileFormat
                        Application.DisplayAlerts = True
                        WorkbookSaved = True
                    End If
                End If
            End If
        Loop Until Me.Saved
    Else
        Application.DisplayAlerts = False
        Me.Save
        Application.DisplayAlerts = True
        WorkbookSaved = True
    End If
    
    'Call the ShowAllSheets routine
    Call ShowAllSheets
    
    'Activate the prior active sheet
    ActiveSht.Activate
    
    'Set the workbook's Saved property
    If WorkbookSaved Then
        Me.Saved = True
    Else
        Me.Saved = OrigSaved
    End If
    
    'Turn on screen updating
    Application.ScreenUpdating = True
    
    'Turn on events
    Application.EnableEvents = True
    
End Sub

 

[ياسر خليل أبو البراء]

إذا كنت تصدير الملف لـ PDF فيمكنك تسجيل ماكرو بسيط وستحصل على الكود المطلوب دون اللجوء إلى كود طويل وغير مجدي في هذه الحالة ..

أو الأفضل إرفاق ملفك ليساعدك الأخوة الكرام بالمنتدى