.tif uzantılı resimleri a b c sutundakilerle birleştirip pdf olarak saklama

[oydemir]

Arkadaşlar a,b,c,d,e,f,g,h,ı,j,k,l sütunlarında resimlerin adresleri var resimlerin isimleri aynı excelde çağırırken çok kolay oluyordu fakat şimdi tek dosyada pdf uzantılı olsun isteniyor yer kazanmak amacı ile bunları birleştirip tek dosya yapıla bilir mi .ilginize teşekkür ederim

 

[askm]

Resimlerin boyutlarına bakılması gerekli diye düşünüyorum. Ya da resimlerin boyutunu sabit yapmak gerekli.
Yani örnek resimler ile birlikte olmasını istediğiniz şekli manuel ekleyerek örnek bir dosya oluşturun, oluşturduğunuz dosyaya göre kod yazalım.

 

[oydemir]

teşekkürler

İlk önce ilginize teşekkür ederim. Dosyanın boyu büyük olduğu için gönderemiyorum.
15 tane klasör var bu klasörlerin içinde 1.tif adlı dosyalar var. Bu dosyaların boyutları 0.870 ile 13.00 kb arasında değişmektedir. Bunları pdf olarak birleştirdiğimde 11 sayfa 10.88 MB , 4.88 MB arasında değişiyor.
C:\Users\aa\198.tif dikteki boyut 4.38 MB (4,598,784 bayt) 13.68 MB (13,800,001 bayt)

C:\Users\bb\198.tif 4.38 MB (4,598,784 bayt) 13.68 MB (13,800,001 bayt)

C:\Users\cc\198.tif 4.38 MB (4,598,784 bayt) 13.68 MB (13,800,001 bayt)

C:\Users\dd\63.tif 4.38 MB (4,598,784 bayt) 13.68 MB (13,800,001 bayt)

C:\Users\ee\198.tif 4.38 MB (4,598,784 bayt) 13.68 MB (13,800,001 bayt)

C:\Users\ff\198.tif 4.38 MB (4,598,784 bayt) 13.68 MB (13,800,001 bayt)

C:\Users\gg\198.tif 4.38 MB (4,598,784 bayt) 13.68 MB (13,800,001 bayt)

C:\Users\hh\198.tif 4.38 MB (4,598,784 bayt) 13.68 MB (13,800,001 bayt)

C:\Users\kk\198.tif 4.38 MB (4,598,784 bayt) 13.68 MB (13,800,001 bayt)

C:\Users\ll\198.tif 4.38 MB (4,598,784 bayt) 13.68 MB (13,800,001 bayt)

C:\Users\tum\tum.pdf


teşekkürler

 

[halit3]

Bu şekilde cevap yazmak çok zor örnek dosya ekliyorum resimleri sayfaya aldım ve sayfayıda pdf olarak kayıt yaptım.

Buna benzer bir şey mi yapmak istiyorsunuz.

 

[oydemir]

halit bey teşekkür ilğinize teşekkür ederim.ama dosyayı tekrar yüklerseniz çok sevinirim arşiv biçimi tanınmıyor veya arşiv hasarlı hatası alıyorum.

 

[halit3]

Yüklediğim dosyayı ben indirdim gayet güzel açılıyor

 

[oydemir]

Halit bey teşekkür ederim. Sizin düşündüğünüz mantıktan düşünmemiştim ama daha güzel olabilir. Ben daha önce formda bulduğun kotları kendime göre uyarlaya bildiğim kadar uyarladım. İşimi baya görüyordu. Ekrana aldığım resimleri yazdırıp gerekli yere veriyordum. Fakat şimdi dijital ortamda pdf uzantılı olarak istendi o yüzden böyle bir şey yapılabilir mi diye sizlere sordum sizden aldığım cevap yapılabildiğini kanıtladı sizden aldığım dosyadaki kotları formdan bulduğum kotlara ekledim fakat resimler gelmedi. Sadece boş sayfalar geldi. Bu sayfalar dolu gelirse benim için süper olur. Birde pdf uzantılı dosyayı saklarken Q3 VE T3 Hücrelerine yazılan isimle saklaya bilir mi . ilginize teşekkür ederim (bu arada kot yazmasını bilmiyorum. Hücre isimlerini değiştiriyorum)
'Private Sub Worksheet_Activate()
'[A1] = ActiveSheet.Name
'End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
On Error Resume Next
Dim resim As Picture, alan As Range
'Set Alan = Range("b4:b6")
For Each resim In ActiveSheet.Pictures
If Not Intersect(resim.TopLeftCell, alan) Is Nothing Then
resim.Delete
End If
Next

Set alan = Nothing
Range("BT2").Select
resimadi = LoadPicture("")
resimadi = Range("Q3").Text & ".tif"
ActiveSheet.Pictures.Insert("//d/dd/Kcc/ee/vatandas_dilekce/" & resimadi).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 800 'yükseklik
Selection.ShapeRange.Width = 500 'genişlik
Selection.ShapeRange.Rotation = 0#
Application.ScreenUpdating = True
Set alan = Nothing
Range("BT2").Select
resimadi = LoadPicture("")
resimadi = Range("T3").Text & ".tif"
ActiveSheet.Pictures.Insert("//d/dd/Kcc/ee/vv/vatandas_dilekce/" & resimadi).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 800 'yükseklik
Selection.ShapeRange.Width = 500 'genişlik
Selection.ShapeRange.Rotation = 0#
Application.ScreenUpdating = True
Set alan = Nothing
Range("CN2").Select
resimadi = LoadPicture("")
resimadi = Range("Q3").Text & ".tif"
ActiveSheet.Pictures.Insert("//d/dd/Kcc/ee/vv/vatandas_hesap/" & resimadi).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 800 'yükseklik
Selection.ShapeRange.Width = 500 'genişlik
Selection.ShapeRange.Rotation = 0#
Application.ScreenUpdating = True
Set alan = Nothing
Range("CN21").Select
resimadi = LoadPicture("")
resimadi = Range("T3").Text & ".tif"
ActiveSheet.Pictures.Insert("//d/dd/Kcc/ee/vv/vatandas_hesap/" & resimadi).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 800 'yükseklik
Selection.ShapeRange.Width = 500 'genişlik
Selection.ShapeRange.Rotation = 0#
Application.ScreenUpdating = True
Set alan = Nothing
Range("DH2").Select
resimadi = LoadPicture("")
resimadi = Range("Q3").Text & ".tif"
ActiveSheet.Pictures.Insert("//d/dd/Kcc/ee/vv/tapu/" & resimadi).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 800 'yükseklik
Selection.ShapeRange.Width = 500 'genişlik
Selection.ShapeRange.Rotation = 0#
Application.ScreenUpdating = True
Set alan = Nothing
Range("DH2").Select
resimadi = LoadPicture("")
resimadi = Range("T3").Text & ".tif"
ActiveSheet.Pictures.Insert("//d/dd/Kcc/ee/vv/tapu/" & resimadi).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 800 'yükseklik
Selection.ShapeRange.Width = 500 'genişlik
Selection.ShapeRange.Rotation = 0#
Application.ScreenUpdating = True
Set alan = Nothing
Range("EB2").Select
resimadi = LoadPicture("")
resimadi = Range("Q3").Text & ".tif"
ActiveSheet.Pictures.Insert("//d/dd/Kcc/ee/vv/anlasma/" & resimadi).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 800 'yükseklik
Selection.ShapeRange.Width = 500 'genişlik
Selection.ShapeRange.Rotation = 0#
Application.ScreenUpdating = True
Set alan = Nothing
Range("EB2").Select
resimadi = LoadPicture("")
resimadi = Range("T3").Text & ".tif"
ActiveSheet.Pictures.Insert("//d/dd/Kcc/ee/vv/anlasma/" & resimadi).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 800 'yükseklik
Selection.ShapeRange.Width = 500 'genişlik
Selection.ShapeRange.Rotation = 0#
Application.ScreenUpdating = True
Set alan = Nothing
Range("EQ10").Select
resimadi = LoadPicture("")
resimadi = Range("c1").Text & ".tif"
ActiveSheet.Pictures.Insert("//d/dd/Kcc/ee/vv/ktk/" & resimadi).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 545 'yükseklik
Selection.ShapeRange.Width = 800 'genişlik
Selection.ShapeRange.Rotation = 90#
Application.ScreenUpdating = True
Set alan = Nothing
Range("FP2").Select
resimadi = LoadPicture("")
resimadi = Range("FQ6").Text & ".tif"
ActiveSheet.Pictures.Insert("//d/dd/Kcc/ee/vv/OLUR/" & resimadi).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 800 'yükseklik
Selection.ShapeRange.Width = 500 'genişlik
Selection.ShapeRange.Rotation = 0#
Application.ScreenUpdating = True
Set alan = Nothing
Range("GJ2").Select
resimadi = LoadPicture("")
resimadi = Range("GK6").Text & ".tif"
ActiveSheet.Pictures.Insert("//d/dd/Kcc/ee/vv/OLUR/" & resimadi).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 800 'yükseklik
Selection.ShapeRange.Width = 500 'genişlik
Selection.ShapeRange.Rotation = 0#
Application.ScreenUpdating = True
Set alan = Nothing
Range("HD2").Select
resimadi = LoadPicture("")
resimadi = Range("HE6").Text & ".tif"
ActiveSheet.Pictures.Insert("//d/dd/Kcc/ee/vv/OLUR/" & resimadi).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 800 'yükseklik
Selection.ShapeRange.Width = 500 'genişlik
Selection.ShapeRange.Rotation = 0#
Application.ScreenUpdating = True

Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveSheet.PageSetup.PrintArea = ""
ActiveSheet.PageSetup.PrintArea = "BS1: IP56"
yol = ThisWorkbook.Path
say = CreateObject("Scripting.FileSystemObject").getfolder(yol).Files.Count + 1
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=yol & "\pdf dosyası " & say & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True

ActiveWorkbook.Close False

MsgBox "İşlem Tamam", vbInformation, " U Y A R I "

End Sub

 

[halit3]

kodları buraya eklemişsiniz resim eklenmiş küçük bir dosya örneğini ekleyin bir bakalım ilk mesajda eklediğiniz dosyada hiç resim yok resimlerin konumu çok önemli resimler hangi hücrede ne kadar büyükler bunlar onun için önemli küçük bir örnek dosya ekleyin yoksa bu şekilde cevap yazmayacağım.

 

[oydemir]

halit bey pdf yaptım bu normalde tif uzantılı olarak saklı.a4 boyutunda çıktı alıyorum. Teşekkür ederim

 

[oydemir]

asadaki şekilde ayarlayıp a4 boyutunda alıyorum bazen arkalı önlü olduğunda arkalı önlü tarayıp birleştirdikten sonra dik konumda saklıyorum çıktıda (uzun kenar yukarıya gelecek şekilde )a4 iki yarsına yazıyor
Selection.ShapeRange.Height = 800 'yükseklik
Selection.ShapeRange.Width = 500 'genişlik

 

[halit3]

Benim imza bölümümde yazıyor dosyanız özel olabilir benim eklediğim dosya gibi dosyanıza farklı resimler ekleyin hangi hücrede ne şekilde görünüyor bunu görmek lazım sizden orjinal dosya ve bilgilerinizi istemiyorum sadece dosyanızın fiziki durumu nasılsa farklı resimler ekleyin örneğin bu ekran görüntüsü olabilir veya küçük resimler olabilir.

 

[oydemir]

halit bey ekran görüntüsünü teşekkürler

 

[oydemir]

halit bey Q3 ve T3 hücresine istediğim resimlerin ismi yazınca önceki gönderdiğim ekran alıntısı gibi resinleri a4 fornuna göre getiriyor.burdanda yazıca gönderiyorum. teşekkürler

 

[oydemir]

Sub tobloları_pdf_yap()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveSheet.PageSetup.PrintArea = ""
ActiveSheet.PageSetup.PrintArea = "b2:b6"
yol = ThisWorkbook.Path
say = CreateObject("Scripting.FileSystemObject").getfolder(yol).Files.Count + 1
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=yol & "\pdf dosyası " & say & ".pdf", _[/COLOR]Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True

ActiveWorkbook.Close False

MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

Halit bey teşekkür ederim yukarda ki kot işimi gördü yalnız istediğim pdf dosyasını kayıt ederken ÖDEME sayfasında Q3 dolu olduğunda Q3 Q3 Boş olduğunda t3 hücresine yazılan isimle kaydedebilir mi?
Örnek:
Q3 hücresinde 1_1 yazıyor ise
C:\Users\kadir\Desktop\Taramapdf\1_1.pdf gibi
Q3 hücresi boş T3 Hücresinde 2_2-1 yazıyor ise
C:\Users\kadir\Desktop\Taramapdf\2_2-1.pdf gibi

 

[halit3]

kod:

Sub tobloları_pdf_yap()

ActiveSheet.PageSetup.PrintArea = ""
ActiveSheet.PageSetup.PrintArea = "b2:b6"
If Cells(3, "Q") <> "" Then
dosya = Cells(3, "Q").Value
Else
dosya = Cells(3, "T").Value
End If
yol = "C:\Users\kadir\Desktop\Taramapdf\"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=yol & dosya & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

 

[oydemir]

teşekkürler elelrinize sağlık