Farklı Kaydet Koduna Pdf ekleme sorunu

[KN0820822]

Merhaba Değerli Üstatlarım,

Aylar öncesinde Halit Üstadımdan almış olduğum yardımlarından sonra ve hiç bugüne kadar problemsiz çalışan aşağıda ki farklı kaydet komutunun içine entegre edilebilecek pdf formatında kayıt etmesi için kod aramakla birlikte yardımlarınızı da beklemekteyim.

Şimdiden EMEĞİ geçen tüm Üstat ve Arkadaşlara teşekkür ederim.

Kullanılan Kod:
Private Sub CommandButton1_Click() 'Farklı Kaydet Komutu
Dosya_adi = Cells(11, "C").Value & "_" & Cells(11, "AO").Value & "_" & Cells(12, "AO").Value
Sayfa_adi = "OF"
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
For i = Len(ThisWorkbook.Name) To 1 Step -1
If Mid(ThisWorkbook.Name, i, 1) = "." Then
Uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
Exit For
End If
Next
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
If Uzanti = ".xls" Then
FileFormatNum = -4143
ElseIf Uzanti = ".xlsm" Then
FileFormatNum = 52
ElseIf Uzanti = ".xlsx" Then
FileFormatNum = 51
ElseIf Uzanti = ".xlsb" Then
FileFormatNum = 50
Else
FileFormatNum = 56
End If
Sheets(ActiveSheet.Name).Copy
Sheets(ActiveSheet.Name).Name = Sayfa_adi
ActiveWorkbook.SaveAs Kaynak & Dosya_adi & Uzanti, FileFormat:=FileFormatNum
ActiveWorkbook.Close False
Cells(12, "AO").Value = Cells(12, "AO").Value + 1 'Kapatma işlemi sonrası kayıt için EVET butonu teklif numarası artmasını sağlar
MsgBox "işlem tamam.?", vbInformation, "uyarı!"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub

 

[Emir Hüseyin Çoban]

. . .

Kırmızı satırları ilave ederek deneyiniz...

Ancak profilinizde Office 2003 yazıyor. Bu sürümün PDF çevirme özelliği yoktur.
Office 2007 sürümünde saveaspdfandxps ek yazılımını yüklemeniz gerekiyor.
2010 ve diğer üst sürümlerde kendi içinde çevirme programı yüklü geliyor.

Sub kod() 'Farklı Kaydet Komutu
    Dosya_adi = Cells(11, "C").Value & "_" & Cells(11, "AO").Value & "_" & Cells(12, "AO").Value
    Sayfa_adi = "OF"
    Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
    If Not Klasor Is Nothing Then
        Kaynak = Klasor.SELF.Path
        If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
        For i = Len(ThisWorkbook.Name) To 1 Step -1
            If Mid(ThisWorkbook.Name, i, 1) = "." Then
                Uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
                Exit For
            End If
        Next
        If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
        If Uzanti = ".xls" Then
            FileFormatNum = -4143
            ElseIf Uzanti = ".xlsm" Then
            FileFormatNum = 52
            ElseIf Uzanti = ".xlsx" Then
            FileFormatNum = 51
            ElseIf Uzanti = ".xlsb" Then
            FileFormatNum = 50
        Else
            FileFormatNum = 56
        End If
        Sheets(ActiveSheet.Name).Copy
        Sheets(ActiveSheet.Name).Name = Sayfa_adi
        ActiveWorkbook.SaveAs Kaynak & Dosya_adi & Uzanti, FileFormat:=FileFormatNum
        
[COLOR="DarkRed"]        yol = Kaynak & Dosya_adi & ".pdf"
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=yol, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        [/COLOR]
        ActiveWorkbook.Close False
        Cells(12, "AO").Value = Cells(12, "AO").Value + 1 'Kapatma işlemi sonrası kayıt için EVET butonu teklif numarası artmasını sağlar
        MsgBox "işlem tamam.?", vbInformation, "uyarı!"
    Else
Atla:
        MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
    End If
    
End Sub

. . .

 

[KN0820822]

Emir Hüseyin Çoban Arkadaşıma çok ama çok teşekkür ederim. Muhteşem bir şekilde çalıştı.