Seçili Hücrelerin Ekran Görüntüsünü Almak

[TEGCreative]

Merhabalar. Sitenizden faydalanarak yapmış olduğum bir programım var. Takıldığım bir noktada yardımlarınızı bekliyorum.
"yazdır" isimli sayfamdaki A1:E20 aralığını userformumdaki image nesnesine almak istiyorum. Nasıl bir yol izlemeliyim ?
Yardımlarınızı bekliyorum. Mutlu hafta sonları

 

[halit3]

Bence bu iş için en uygun operatör (clipbrd.clipboard)

Private Sub CommandButton1_Click()
Dim myClp As Object
Set myClp = CreateObject("clipbrd.clipboard")
myClp.Clear

Worksheets("yazdır").Range("A1:E20").CopyPicture Appearance:=xlScreen, Format:=xlBitmap

Image1.Picture = myClp.GetData 'PastePicture

MsgBox "İŞLEM TAMAM"""
End Sub

bu kodu bir dene
not clipboard.dll dosyası bilgisayarınızda yüklü olmalı

 

[igultekin2000]

iyi günler;
Dll dosyasını system32 klasörüne kopyaladım. verdiğiniz kodu butona bağladım, commond butonunu tıkladığımda hata veriyor.

 

[TEGCreative]

Bence bu iş için en uygun oparatör (clipbrd.clipboard)

Private Sub CommandButton1_Click()
Dim myClp As Object
Set myClp = CreateObject("clipbrd.clipboard")
myClp.Clear

Worksheets("yazdır").Range("A1:E20").CopyPicture Appearance:=xlScreen, Format:=xlBitmap

Image1.Picture = myClp.GetData 'PastePicture

MsgBox "İŞLEM TAMAM"""
End Sub

bu kodu bir dene
not clipboard.dll dosyası bilgisayarınızda yüklü olmalı

Sayın halit3 ; ilginiz ve hızınız için çok teşekkürler. Dosyayı Windows/System32 içerisine kopyaladım ve denedim fakat

Set myClp = CreateObject("clipbrd.clipboard")

hatası alıyorum.

 

[halit3]

örnek dosyanızı ekleyin bir bakalım ben bir tane reg yapan kendi proğramımı ekliyorum dosyayı yönetici olarak aç nesneyi seç ve (seçilenlerin hepsini yükle aktar) düğmesine tıkla

 

[Korhan Ayhan]

Ekli dosyayı deneyiniz.

 

[halit3]

Bir dosyada ben ekliyorum iki türlü resim alma userformu var

 

[Haluk]

Ben de bir alternatif ekleyeyim ....

Eğer UserForm üzerindeki Image1 nesnesi, görüntülenecek resime uygun boyutlardaysa;

Private Sub CommandButton1_Click()
    Dim MyRange As Range
    Dim TempFile As String

    TempFile = Environ("tmp") & Application.PathSeparator & "TempPic.jpg"
   
    Set MyRange = ActiveSheet.Range("A1:F10")

    With ActiveSheet.ChartObjects.Add(Left:=MyRange.Left, Top:=MyRange.Top, Width:=MyRange.Width, Height:=MyRange.Height)
        .Name = "TempChart"
        .Activate
    End With
   
    MyRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture
   
    ActiveChart.Paste
    With ActiveSheet.ChartObjects("TempChart")
        .Chart.Export (TempFile)
        .Delete
    End With
   
    Image1.Picture = LoadPicture(TempFile)
   
    Image1.PictureSizeMode = fmPictureSizeModeStretch
    Kill TempFile
   
    Set MyRange = Nothing
End Sub

Eğer, UserForm1 üzerindeki Image1 nesnesinin boyutlarını, resmi alınan hücre aralığına göre otomatik olarak boyutlandırlmasını isterseniz ....... (bu durumda resmi net olarak görüntülersiniz)

Private Sub CommandButton1_Click()
    Dim MyRange As Range
    Dim TempFile As String
   
    TempFile = Environ("tmp") & Application.PathSeparator & "TempPic.jpg"
   
    Set MyRange = ActiveSheet.Range("A1:F10")

    With ActiveSheet.ChartObjects.Add(Left:=MyRange.Left, Top:=MyRange.Top, Width:=MyRange.Width, Height:=MyRange.Height)
        .Name = "TempChart"
        .Activate
    End With
   
    MyRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture
   
    ActiveChart.Paste
    With ActiveSheet.ChartObjects("TempChart")
        .Chart.Export (TempFile)
        .Delete
    End With
   
    Image1.Picture = LoadPicture(TempFile)
   
    Image1.Width = MyRange.Width
    Image1.Height = MyRange.Height
    Image1.PictureSizeMode = fmPictureSizeModeStretch
    Kill TempFile
   
    Set MyRange = Nothing
End Sub

Ben Image1 nesnesinde görüntülenecek alanı A1:F10 olarak belirledim, siz kendinize göre değiştirebilirsiniz.

.

 

[TEGCreative]

Sayın Korhan , halit3 ve Haluk hocam ; ilginiz için çok teşekkürler. Haluk hocam'ın verdiği kod tam istediğim gibi çalıştı. Fakat diğer kodlarda yine aynı şekilde obj hatası aldım. Nedendir bilinmez dosyayı yüklediğim halde aynı hatayı verdi. Teşekkürler excel.web

 

[halit3]

Merhaba Haluk Bey
Ben sizin kodlarınızı çalıştırdığımda seçili alanın görüntüsü beyaz boş çerçeve çıkıyor.
Sayın TEGCreative sizde bu resimler nasıl çıkıyor yani userformda nasıl gözüküyor.
Haluk Beyin yazdığı kodla oluşan resmi ve kendi yazdığım kodla oluşan resimleri ekliyorum ayrıca ilgili sayfanında ekran görüntüsünüde ekliyorum.

 

[Haluk]

 

[halit3]

Herhalde işletim sisteminden kaynaklanıyor
Windows7 32 bit ,ofis 2003 ve ofis 2007

 

[halit3]

Bu kod bende çalışıyor

Private Sub CommandButton3_Click()

Kayıt_Yeri = ThisWorkbook.Path & "\"
Dosya_Adı = Kayıt_Yeri & "Picture777.jpg"
Dim resim As Range: Set resim = ActiveSheet.Range("A1:F10") 'Range(ActiveWindow.RangeSelection.Address)

resim.CopyPicture Appearance:=xlScreen, Format:=xlBitmap

With ActiveSheet.ChartObjects.Add(Left:=resim.Left, Top:=resim.Top, _
Width:=resim.Width, Height:=resim.Height)
.Name = "picture777"
.Activate
End With
ActiveChart.Paste
ActiveSheet.ChartObjects("picture777").Chart.Export Dosya_Adı
ActiveSheet.ChartObjects("picture777").Delete
Image1.Picture = LoadPicture(None)
Image1.Picture = LoadPicture(Dosya_Adı)
Kill Dosya_Adı

End Sub

 

[Haluk]

Halit Bey, ekli dosyayı deneyebilirsiniz...

.

 

[byguvezz]

Bunun için kod yazmaya gerek yok aslında. Seçili hücrelerin dinamik bir şekilde image'ını almak mümkün. Hatta içinde başka şekiller ve nesneler de varsa, katmanların düzleştirilmiş halini almış oluyorsunuz. Aşağıdaki yönergeleri izleyin:
Dosya > Seçenekler > Şeridi Özelleştir > 'Popüler Komutlar'ı açılır listeden 'Tüm Komutlar' yap > altındaki listede 'Kamera' seçeneğini bul > Karşı tarafa aktar (eğer ilk defa bu tarz bir ekleme yapıyorsanız öncelikle 'yeni grup oluştur'u kullanın ve oluşturduğunuz grubu seçtikten sonra aktarmayı deneyin.

Çözemeyen olursa resimli anlatım ekleyebilirim.

Artık fonksiyon kullanmaya hazır. Tek yapmamız gereken image almak istediğimiz alanı seçip kamera butonuna basmak ve image dosyasını üreteceği müsait bir hücreye tıklamak.

 

[Haluk]

Bunun için kod yazmaya gerek yok aslında.

Soruyu tam okumadınız galiba ...... Seçili alanın resmi UserForm üzerindeki Image nesnesine aktarılacak ....

.

 

[halit3]

Sorun aslında ilk yazdığınız kod ile ilgili

MyRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture

bu bölüm

Set MyRange = ActiveSheet.Range("A1:F10")

bundan sonra olacak
böyle yapınca kod bende çalıştı

Private Sub CommandButton1_Click()
Dim MyRange As Range
Dim TempFile As String
TempFile = Environ("tmp") & Application.PathSeparator & "TempPic.jpg"
Set MyRange = ActiveSheet.Range("A1:F10")
MyRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With ActiveSheet.ChartObjects.Add(Left:=MyRange.Left, Top:=MyRange.Top, Width:=MyRange.Width, Height:=MyRange.Height)
.Name = "TempChart"
.Activate
End With

ActiveChart.Paste
With ActiveSheet.ChartObjects("TempChart")
.Chart.Export (TempFile)
.Delete
End With
Image1.Picture = LoadPicture(TempFile)
Image1.PictureSizeMode = fmPictureSizeModeStretch
Kill TempFile
Set MyRange = Nothing
End Sub

 

[Haluk]

Eklediğim dosyada zaten dediğiniz gibi...

.

 

[halit3]

Bu dosya da birazcık farklı uygulama api kodları ile yapılmıştır.