Bilgi kartı Jpg dosya kaydetme

[cenqawer]

Merhaba ekte verdiğim excelde ki gibi bilgi kartları oluşturmam gerekiyor. jpd olarak heerhangi bir klasöre jpg adınında kayıt numarası olarak kaydedilmesi gerekiyor . Makro olarak yardımcı olabilirseniz çok sevinirim

 

[bmutlu966]

Deneyiniz.

 

[cenqawer]

işte budur ya Gerçekten çok teşekkür ederim allah razı olsun.

Birde resmin içindeki kutucukta bi sorun var çözüm cevabı uzun olduğunda hepsi gelmiyor belli bir kelimeden sonrasını çekmiyor düzeltilebilir mi

 

[cenqawer]

Tekrar merhaba metin kutusunda sayı sınırı olduğundan uzun cevapları veremedim bunun yerine sol tarafa açılan kutusu koysak ilk sayfadaki numaranın çözüm cevabını metin kutusunun içine kopyalasa olabilir mi en azından uzunluk sınırı olmaz

 

[Mdemir63]

Selamlar
Metin kutusunu seçin>Sağ Klik Özellikler>Metin Kutusu>Şekli metin sığacak şekilde boyutlandır kısmını tıklayın

 

[cenqawer]

onu denedim fakat yine olmuyor belli bir karakter sayısı var onu aşmama izin vermiyor

 

[Mdemir63]

onu denedim fakat yine olmuyor belli bir karakter sayısı var onu aşmama izin vermiyor

Evet haklısınız.
Denemeden yazdığım için kusura bakmayın

 

[Mdemir63]

Selamlar
Resim olarak değil de Pdf olarak yapmaya çalıştım. Umarım işinize yarar.
Deneyiniz.

 

[cenqawer]

Bu şekilde bir box paylaşım sitesinde kartlar çok küçük görünüyor jpeg olarak işi görecek peki en azından bu pdf olarak yaptığınızı örnek B1.D13 gibi bir alanı seçip jpg yapamaz mı Mutlu Bey in ilk yaptığı mantık resim yerine seçili alanı yaparız en azından

 

[bmutlu966]

O zaman bu şekilde deneyin

 

[cenqawer]

Çok teşekkür ederim elinize emeğinize sağlık harika oldu

 

[cenqawer]

Tekrar Merhaba bu formatta çok uzun olan cevaplarda görüntü sorunu oluyor çözünürlük kalitesini belirleye biliyor muyuz örnek aynı yazıyı power pointte jpeg olarak aldığım baya büyütmeme rağmen yazılar bulanıklaşmıyor

 

[cenqawer]

Yada şöylede olabilir seçili alanı iki katına çıkartırım ama makroda seçili alanı neresi belirliyor H2:M87 değiştirsem bile aynı alandaki miktarı alıyor




Sub Resimolarakkaydet()

Dim oWs As Worksheet
Dim oRng As Range
Dim oChrtO As ChartObject
Dim lWidth As Long, lHeight As Long

Set oWs = ActiveSheet
Set oRng = oWs.Range("H2:M87")

If Range("A8") = "" Then MsgBox "Lutfen dosyanin kaydedilecegi klasor yolunu giriniz.", vbCritical: Range("A8").Select: Exit Sub

oRng.CopyPicture x1Screen, xlPicture
lWidth = oRng.Width
lHeight = oRng.Height

Set oChrtO = oWs.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)

oChrtO.Activate
With oChrtO.Chart
.Paste
.Export Range("A8") & Range("A2") & ".jpg"
End With

oChrtO.Delete

End Sub

 

[bmutlu966]

Kodu değiştirmenize gerek yok. D5 hücresinin ayarlarıyla oynamanız gerek. Büyütüp küçültebilir veya fontu büyütebilir veya rengini değiştirebilirsiniz. Kod bu alanı jpg çıktısı olarak verir. Örnek olarak dosyanızdaki hem alanı hem de fontu büyüttüm. Siz kendinize göre ayarlarsınız.

 

[cenqawer]

Aynen oldu ekranı ne kadar büyütürsem o kadar büyüyor birde ileri sayfalara geçince sayfa geride kaldğından o kısmı almıyormuş dediğiniz gibi. Çok teşekkür ederim

 

[cenqawer]

Tekrar rahatsız ediyorum kusura bakmayın bu arada gerçekten formülünüzü kullanıyorum çok işime yaradı çok kolay çalışıyor sadece arada bir hata veriyor ama neden hata verdiğini anlayamadım





Sub Resimolarakkaydet()

Dim oWs As Worksheet
Dim oRng As Range
Dim oChrtO As ChartObject
Dim lWidth As Long, lHeight As Long

Set oWs = ActiveSheet
Set oRng = oWs.Range("H2:M82")

If Range("A8") = "" Then MsgBox "Lutfen dosyanin kaydedilecegi klasor yolunu giriniz.", vbCritical: Range("A8").Select: Exit Sub
If Len([H11]) <= 404 Then [H11].Font.Size = 50
If Len([H11]) > 405 And Len([H11]) <= 813 Then [H11].Font.Size = 35
If Len([H11]) > 814 And Len([H11]) <= 1100 Then [H11].Font.Size = 33
If Len([H11]) > 1101 And Len([H11]) <= 1500 Then [H11].Font.Size = 28
If Len([H11]) > 1501 And Len([H11]) <= 1900 Then [H11].Font.Size = 25
If Len([H11]) > 1901 And Len([H11]) <= 2300 Then [H11].Font.Size = 23
If Len([H11]) > 2301 And Len([H11]) <= 2700 Then [H11].Font.Size = 21
If Len([H11]) > 2701 And Len([H11]) <= 3100 Then [H11].Font.Size = 19
If Len([H11]) > 3101 And Len([H11]) <= 3400 Then [H11].Font.Size = 17
If Len([H11]) > 3401 And Len([H11]) <= 3800 Then [H11].Font.Size = 15
If Len([H11]) > 3801 And Len([H11]) <= 5200 Then [H11].Font.Size = 12
oRng.CopyPicture xlScreen, xlPicture
lWidth = oRng.Width
lHeight = oRng.Height

Set oChrtO = oWs.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)

oChrtO.Activate
With oChrtO.Chart
.Paste
.Export Range("A8") & Range("A2") & ".jpg"
End With

oChrtO.Delete

End Sub