pdf e çeviriken resim bozuluyor.

[kamenzü]

merhaba,

çalışma sayfalarını tek tek pdf olarak kaydeden bir makrom var.

yaklaşık 3 gündür kaydedilen pdf dosyalarındaki resimler bozuk (Ya da kare kare) çıkıyor.

ancak, sayfaları kendim pdf olarak kaydedersem resimler düzgün görünüyor.

Sorunu bulamadım.

kodları barındıran dosyanın daha eski sürümünü denedim, düzelmedi,

farklı bir excel dosyasını denedim, düzelmedi,

Örnek excel dosyası ve makroyu barındıran eklenti dosyasının linki ektedir.

ayrıca kodun ilgili kısmını da aşağıya ekledim.

https://onedrive.live.com/redir?resid=7A325CDD0A0FEBDC!142359&authkey=!ADu-xicZAFMtUdo&ithint=folder%2cxlsx

''''''''''''''''''''''''''''''''''''''''''''''''''''''
' BU KISIM KALİTE DOKÜMANLARINI PDF'E ÇEVİRİR.
''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub dokuman_pdf_Click()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.StatusBar = False

modul_bilgisi = Sheets("Bilgiler").[b37].Value


Worksheets("Bilgiler").Select


ActiveSheet.Next.Select

' yoksa "dokümanlar" klasörünü oluşturur.

If Len(Dir(ActiveWorkbook.Path & Application.PathSeparator & "dokümanlar", vbDirectory)) = 0 Then
   MkDir ActiveWorkbook.Path & Application.PathSeparator & "dokümanlar"
End If


' modüle göre işlem yapılması için kriteri belirler.


' sayfa "kayıtlar" klasörüne dahil edilecek mi? kontrol eder.
' dosyaya dahil edilmeyecek kayıtları seçmek için tarihi kontrol eder.
' sayfa kayıtlar klasörüne dahil edilmeyecek ise bir sonraki sayfa bölümüne havale eder
' (sonraki sayfa bölümü; sonraki sayfaya geçip yeniden kontrol için kontrol et bölümüne yönlendirir.)

kontrol_et:

If modul_bilgisi <> "B+E" Then
    GoTo modul_h
    ElseIf Range("A2").Value <> "B+E" Then
    GoTo sonraki_sayfa
        ElseIf Range("L2").Value <> "" Then
        Call yeni_excel_dosyası
        GoTo sonraki_sayfa
            ElseIf Range("B2").Value = "" Then
            GoTo sonraki_sayfa
                ElseIf Range("G2").Value < Date + 45 Then
                GoTo sayfayi_kaydet
                    Else
                    GoTo sonraki_sayfa
End If
modul_h:

If Range("L2").Value <> "" Then
    Call yeni_excel_dosyası
    GoTo sonraki_sayfa
        ElseIf Range("B2").Value = "" Then
        GoTo sonraki_sayfa
        ElseIf Range("G2").Value < Date + 45 Then
        GoTo sayfayi_kaydet
            Else
                GoTo sonraki_sayfa
End If

' sayfa, son çalışma sayfası ise kaydet ve bitir bölümüne havale eder.

sonraki_sayfa:

If ActiveSheet.Name = "SON" Then GoTo bitis Else ActiveSheet.Next.Select
GoTo kontrol_et
    
' sayfayı PDF olarak kaydeder.

sayfayi_kaydet:
    
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=ActiveWorkbook.Path & Application.PathSeparator & "dokümanlar" & Application.PathSeparator & Range("B2").Value & ".pdf" _
        , Quality:=xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False
GoTo sonraki_sayfa

bitis:

Worksheets("sürüm kaydı").Select

Dim i As Long
For i = 1 To 5000000
a = a + i
Next i
Beep ' Bu komut bip sesi verir.
i = Empty
For i = 1 To 20000000
a = a + i
Next i
Beep ' Bu komut bip sesi verir.
i = Empty
For i = 1 To 40000000
a = a + i
Next i
Beep ' Bu komut bip sesi verir.
i = Empty

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.StatusBar = True
Worksheets("Bilgiler").Select
End Sub

 

[kamenzü]

fikri olan var midır?

 

[PLİNT]

Merhaba

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=ActiveWorkbook.Path & Application.PathSeparator & "dokümanlar" & Application.PathSeparator & Range("B2").Value & ".pdf" _
        , [COLOR="Red"]Quality:=xlQualityMinimum[/COLOR], IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False

Kodlarınızın içinde bulunan yukarıdaki kırmızı bölümü; aşağıdaki gibi denedinizmi?

 Quality:=xlQualityStandard

 

[kamenzü]

Merhaba

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=ActiveWorkbook.Path & Application.PathSeparator & "dokümanlar" & Application.PathSeparator & Range("B2").Value & ".pdf" _
        , [COLOR="Red"]Quality:=xlQualityMinimum[/COLOR], IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False

Kodlarınızın içinde bulunan yukarıdaki kırmızı bölümü; aşağıdaki gibi denedinizmi?

 Quality:=xlQualityStandard

evet, denedim, olmadı.

Şu an geçici olarak şöyle bir çözüm buldum.

logoyu normalde durduğu hücreden 4-5 misli büyük ebatta bir alana kopyaladım ve oraya link verdim.

çıkan pdf lerde logo düzeldi.

Ancak 3-4 yıldır işleyen sistemde ne oldu anlayamadım...

 

[kamenzü]

Merhaba

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=ActiveWorkbook.Path & Application.PathSeparator & "dokümanlar" & Application.PathSeparator & Range("B2").Value & ".pdf" _
        , [COLOR="Red"]Quality:=xlQualityMinimum[/COLOR], IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False

Kodlarınızın içinde bulunan yukarıdaki kırmızı bölümü; aşağıdaki gibi denedinizmi?

 Quality:=xlQualityStandard

Kusura bakmayın.

sizin tavsiyenizi denediğimi sanıyordum.

İfadeyi değiştirdikten sonra makroyu kaydetmeden kapatmışım.

Sonra tekrar bir deneme yaptım ve oldu.

Teşekkürler.