Hücre değerine göre Jpeg kaydetme

[excellkurdu]

merhaba arkadaşlar,
ekteki dosya da yardımcı olabilir misiniz?
2 sorunum var;
1. hücre değerlerine göre kaydetme
2. resim boyutlarını ayarlayamadım. Sadece form çıkıtısı nasıl yapabilirim.
Şimdiden teşekkür ederim.

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.

Not: Kodlar alıntıdır.
Kodların içindeki;
Set rngImg = Range("A1:AE44") 'resim alanını burda belirleyin
satırında resim alanı belirlemesi yapabilirsiniz.

 

[excellkurdu]

Hocam kod çalıştı. Fakat resim son hali çok kötü görülüyor. En net görülen PDF formatı. aynı şartlarda kodu PDF ye çevirebilir miyiz? Yani aynı resim kaydetme gibi pdf olarak kaydedebilir miyiz? Dosya ektedir.

 

[muygun]

Merhaba;
Ofis 2003 kullanıyorum. (2007 ve üzeri versiyonları dönüştürücü aracılığı ile açabiliyorum)
İstediğiniz pdf olarak kaydetme işlemi 2007 ve üzerinde (bir eklenti ile) mümkün.
Bunun için site içinde arama yaparsanız ilgili örnek kodlara ulaşabilirsiniz.
İnternette arama yaparak işlemin yapılma yönteminin açıklamalarına ulaşmanızda mümkün.
İyi çalışmalar.

 

[excellkurdu]

Hocam oldu PDF olarak kaydediyorum. Fakat masa üstü yerine AF1 deki ="C:\deneme\" yazan dizine nasıl kaydettirebilirim. Son kod aşağıdadır. Bu kodun neresine AF1 yazarsam o dizine kaydeder? Çok şey denedim ama sürekli masa üsütüne kaydediyor.

Sub farklı_kaytet_pdf()
dosya_adı = Cells(1, "a").Value
If dosya_adı = "C:\deneme\" Then
MsgBox "Dosya adı yok"
Exit Sub
End If
a = MsgBox(" Kayıt etmek istiyormusunuz.?", vbYesNo + vbInformation, " Uyarı")
If a = vbYes Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & dosya_adı, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
MsgBox "işlem tamam!"
End If
If a = vbNo Then
MsgBox "işlemi iptal ettiniz.!"
End If
End Sub

 

[excellkurdu]

Arkadaşlar 5 nolu mesaja cevap veren yok mu. Yardım ederseniz sevinirim.