Makro ile alınan sayfa görüntünün BMP olarak kayıt edilmesi

[akgüvercin]

Öncelikle kolay gelsin tüm arkadaşlara

Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Bu kod ile seçilmiş alanın görüntüsünü alıyorum.

ActiveSheet.Pictures.Paste
Bu kod ile de aldığım görüntüyü yapıştırıyorum.

D = Selection.Width
E = Selection.Height
MsgBox D & (" ----genişliğinde. & ") & E & (" ---yüksekliğinde.")
Bu kod ile de görüntünün genişliğini ve yüksekliğini kontrol ediyorum(veya öyle sanıyorum)

Set graf = ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
StrKlasor = "C:\Resim\": uznKlsr = Len(StrKlasor)
Set Dosyalar = CreateObject("Scripting.FileSystemObject").GetFolder(StrKlasor).Files
For Each dosya In Dosyalar
Ara = Mid$(StrKlasor & Strmetin, uznKlsr + 1, uznMtn)
If Ara = Strmetin Then s = s + 1
Next
With graf
.Paste
.Export StrKlasor & Strmetin & String$(4 - Len(s), "0") & s + 1 & ".bmp"
.Parent.Delete
End With
Bu kod ile de "C:\resim\" klasörüne görüntüleri farklı isim altında kaydediyorum.(bu kodu siteden aldım ve düzenledim)

Sıkıntım ise ;
Oluşturulan bmp dosyalarında

D = Selection.Width
E = Selection.Height
MsgBox D & (" ----genişliğinde. & ") & E & (" ---yüksekliğinde.")

BMP dosyası mesaj kutusunda gösterilen genişlikte ve yükseklikte olmamakta

örnek olarak ;mesaj kutusu 300 genişliğinde 900 yüksekliğinde derken
oluşturulan bmp dosyasındaki ölçekler
100 genişliğinde ve 300 yüksekliğinde

 

[Zeki Gürsoy]

Merhaba,

Uzantıyı "jpg" olarak tanımlayın.

Sub test()
Dim s As Integer, dosya As String
Const StrKlasor As String = "C:\Resim\"
   
d = Dir(StrKlasor & "*.jpg")

If d <> "" Then
    While d <> ""
        s = s + 1
        d = Dir
    Wend
End If

dosya = StrKlasor & "Resim" & String$(5 - Len(s), "0") & s + 1 & ".jpg"
Selection.CopyPicture

Set graf = ActiveSheet.ChartObjects.Add( _
    0, 0, Selection.Width, Selection.Height).Chart
    
    With graf
        .Paste
        .Export dosya
        .Parent.Delete
    End With
    
End Sub

 

[akgüvercin]

Zeki Gürsoy bey teşekkür ederim .
Sonuç aynı.düzelme olmadı.

en iyisi sanırım dosya eklemek.
dosya ".xlsm" formatında

 

[Zeki Gürsoy]

Dosyanızı eklemeniz mümkün mü? Sorun olmaması gerekirdi.

 

[akgüvercin]

Zeki bey bir önceki mesaja ekledim dosyayı.
".jpg" ile kayıt yapmamamın sebebi-Çizgilerdeki renk bozulmaları olması
".bmp" ile kayıt yapınca renk bozulması olmuyor.

 

[Zeki Gürsoy]

2007 şu an yüklü değil, 2003 formatında ekleyebilir misiniz?

 

[akgüvercin]

".xls"olarak eklendi.

 

[Zeki Gürsoy]

Ekranda görünüm ne ise, resim de aynı şekilde çıktığından "zoom" oranını değiştirmeniz gerekiyor.

 

[akgüvercin]

Zeki bey

"Zoom" olayı hiç aklıma gelmemişti...
Burdaki kopyalama olayını manuel yapıyordum .
"Görüntüyü kopyala ,MSpaint'e yapıştır" şeklinde.

İlginiz için teşekkür ederim.

Dip Not: Her iki kod da sorunsuz olarak çalışmakta.