Excelde Seçili Alanın Resmini Çekmek

[hsayar]

Selam Arkadaşlar ;

Diyelimki Mouse ile A1:d5 aralığını seçtik Bir makro ile bu alanın resmini çekecek
ve
Ya kaydetmek istediğimiz konumu soracak, olmazsa Paintte yapıştıracak ben manuel kaydedeceğim.

 

[baydeniro]

Merhaba. Alt tuşuna basılı tutup PrintScreen tuşuna basarak o anda ekranda gmzüken tüm görünütünün fotoğrafının aktarabilirsin. Sadece belirli bir alanın fotoğraflanması ise Paint içinde yapılabilir.

 

[hsayar]

sn serdarokan o dediğiniz elbette biliyorum ama paintte istenilen alana kadar küçültme işi sıkıcı geliyor daha basiit varsa neden olmasın

 

[EKREM1661]

ilişikte eklediğim küçük bir prog.aracı sorunuzla ilgili tüm sorunlarınızı çözer.
kurulum gerektirmez, kullanımı basit ve pratiktir.

 

[hsayar]

teşekkür ederim visdtadaki ekran alıntısı aracının aynısı
Grab Reculatuer Area diyerek sonuca ulaşabiliyorum. sağol

 

[Seyit Tiken]

Örnek dosyayı inceleyinz.

Sub alan_kopyala()
[a1:d5].CopyPicture
End Sub

Sub yapıştır()
ActiveSheet.Paste
End Sub

 

[hsayar]

seyit hocam teşekkür ederim.
istediğim kopyalanan alanın
Resim001.jpg,Resim002.jpg...........Resim100.jpg vs.
olacak şekilde kaydedilmesi

Sub alan_kopyala()
On Error GoTo son
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
GoTo Atla
son:
MsgBox "Birleşik aralıkta bir seçim yapmalısınız"
Atla:
End Sub

Sub yapıştır()
ActiveSheet.Paste
End Sub

Yani Yapıştır makrasunda Resim Sayfaya değil
jpg olarak
Thisworkbook.path\Thisworkbook.name & sırano & ".jpg"
olarak kaydedecek
sırano 001 den başlayacak eğer varsa 002 oda varsa 003 olarak gidecek
001 ve 003 var 002 silinmiş ise 002 adında kaydedecek gb.

 

[Zeki Gürsoy]

Örnek:

Sub Test()
Dim Sayi%
'.
'.
'.
Sayi = CreateObject("Scripting.FileSystemObject").GetFolder("C:\").Files.Count
 
Export "Resim" & String$(3 - Len(Sayi), "0") & Sayi + 1
End Sub

 

[hsayar]

Sub or fonction not defineded hatası alıyorum sn. hocam....

 

[Zeki Gürsoy]

Bunu deneyin.

Sub Range_ScreenShot()
'ActiveSheet.Add(Left, Top, Width, Height)
Dim Pic As Picture, graf As Chart, rg As Range
 
    Set rg = Range("A1:D5")
    rg.CopyPicture
 
    Set Pic = ActiveSheet.Pictures.Paste
 
    With Pic
        .Copy
        .Delete
    End With
 
Set graf = ActiveSheet.ChartObjects.Add(1, 1, rg.Width, rg.Height).Chart
Sayi = CreateObject("Scripting.FileSystemObject").GetFolder("C:\").Files.Count
 
    With graf
        .Paste
        .Export "C:\Resim" & String$(3 - Len(Sayi), "0") & Sayi + 1 & ".jpg"
        .Parent.Delete
    End With
 
End Sub

 

[hsayar]

Teşekkürler hocam Aşağıdaki şekilde kodlarınızı değiştirdim.
Bu şekilde seçili olan hücreler veya metin kutusu ve otomatik şekilleri export ediyorum.

Sn Seyit Diken'in kodlarındaki yapıştır kodu ise seçili olan tüm nesnelerin resmini çekiyordu o şekilde geliştirirsek sevinirim.

Sub Range_ScreenShot()
'ActiveSheet.Add(Left, Top, Width, Height)
'Excelwebtr/anemos
Dim Pic As Picture, graf As Chart, rg 'As Range
    Set rg = Selection
    rg.CopyPicture
 
    Set Pic = ActiveSheet.Pictures.Paste
 
    With Pic
        .Copy
        .Delete
    End With
 
Set graf = ActiveSheet.ChartObjects.Add(1, 1, rg.Width + 2, rg.Height + 2).Chart
Sayi = CreateObject("Scripting.FileSystemObject").GetFolder("C:\").Files.Count
 
    With graf
        .Paste
        .Export "C:\Resim" & String$(3 - Len(Sayi), "0") & Sayi + 1 & ".jpg"
        .Parent.Delete
    End With
End Sub

Ayrıca
Sayi = CreateObject("Scripting.FileSystemObject").GetFolder("C:\Resim").Files.Count


Satırında ilk beş Karakteri resim olanları say desek ve sayımız o olsa mümkünmüdür?

 

[hsayar]

Sonunda hallettim... Değişken tanımlamadan
Hata yapmışım bir yerde düzellttim.

Sub Selection_ScreenShot()
'ActiveSheet.Paste
'Excel.Web.tr\Anemos&SeyitDiken
On Error GoTo hata
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture: GoTo islem
hata:
MsgBox "Birleşik aralıkta bir seçim yapmalısınız": GoTo Son
islem:
    Set Pic = ActiveSheet.Pictures.Paste

    With Pic
        .Copy
        .Delete
    End With
Set graf = ActiveSheet.ChartObjects.Add(1, 1, Selection.Width + 2, Selection.Height + 2).Chart
Sayi = CreateObject("Scripting.FileSystemObject").GetFolder("C:\Resim").Files.Count
 
    With graf
        .Paste
        .Export "C:\Resim\Resim" & String$(3 - Len(Sayi), "0") & Sayi + 1 & ".jpg"
        .Parent.Delete
    End With
Son:
End Sub

Yalnız Sayı değişkeni istediğim gibi değil
Sayi = CreateObject("Scripting.FileSystemObject").GetFold er("C:\Resim").Files.Count

Şu şekilde sayarsa sevinirim

Klasör c:\resim
Metin Thisworkbok.name (.xls si hari&#231 sayacak
yani c:\resim altında mesala kitap1 ile başlayan jpg leri sayacak
buda olursa tam istediğim kıvama gelmiş olur.
alakanız için tümünüze teşekkür ederim

 

[Zeki Gürsoy]

Bazı ilaveler yaptım.
Sn. Seyit Tiken'in verdiği örnekle benzer değil midir?

Sub Range_ScreenShot()
'ActiveSheet.Add(Left, Top, Width, Height)
'Excelwebtr/anemos
Dim Pic As Picture, graf As Chart, rg, s%
 
    Set rg = Selection
    rg.CopyPicture
 
    Set Pic = ActiveSheet.Pictures.Paste
 
    With Pic
        .Copy
        .Delete
    End With
 
Set graf = ActiveSheet.ChartObjects.Add(1, 1, rg.Width + 2, rg.Height + 2).Chart
 
'Dizindeki dosyalar..
Set fl = CreateObject("Scripting.FileSystemObject").GetFolder("C:\Resim").Files
 
For Each dosya In fl
    If Left$(dosya, 5) = "Resim" Then s = s + 1
Next
 
    With graf
        .Paste
        .Export "C:\Resim" & String$(3 - s, "0") & s + 1 & ".jpg"
        .Parent.Delete
    End With
End Sub

 

[hsayar]

hocam teşeküür ederim ama s sayısı artmadığı için daima sıfır buluyor ve hep resim0001.jpg olarak kaydediyor ?

Set Dosyalar = CreateObject("Scripting.FileSystemObject").GetFolder("C:\Resim\").Files

For Each dosya In Dosyalar
MsgBox dosya
    If Left$(dosya, 5) = "Resim" Then s = s + 1
    MsgBox s
Next

 

[Zeki Gürsoy]

Önceki sorunuzdaki isteğinize göre sayacaktır.

metin = Left$(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
 
Dosyalar = Dir("C:\Resim\" & metin & "*.jpg")
 
While Dosyalar <> ""
    s = s + 1: Dosyalar = Dir
Wend
 
MsgBox s

 

[hsayar]

Sonunda

Sub Selection_ScreenShot()
'ActiveSheet.Paste
'Excel.Web.tr\Anemos&SeyitDiken
On Error GoTo hata
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture: GoTo islem
hata:
MsgBox "Birleşik aralıkta bir seçim yapmalısınız": GoTo Son
islem:
    Set Pic = ActiveSheet.Pictures.Paste

    With Pic
        .Copy
        .Delete
    End With
Set graf = ActiveSheet.ChartObjects.Add(1, 1, Selection.Width + 2, Selection.Height + 2).Chart
'Klasör ve Dosyaadı başlangıç metni
StrKlasor = "C:\Resim\":                           uznKlsr = Len(StrKlasor)
Strmetin = ThisWorkbook.Name:                      uznMtn = Len(Strmetin)
'Dizindeki dosyalar..
Set Dosyalar = CreateObject("Scripting.FileSystemObject").GetFolder(StrKlasor).Files
say = CreateObject("Scripting.FileSystemObject").GetFolder(StrKlasor).Files.Count
    
    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$(3 - Len(s), "0") & s + 1 & ".jpg"
            .Parent.Delete
        End With

Son:
End Sub

tekrar teşekkürler sn. anameos ve sn seyitdiken

 

[hsayar]

Sonunda

Sub Selection_ScreenShot()
'ActiveSheet.Paste
'Excel.Web.tr\Anemos&SeyitDiken
On Error GoTo hata
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture: GoTo islem
hata:
MsgBox "Birleşik aralıkta bir seçim yapmalısınız": GoTo Son
islem:
    Set Pic = ActiveSheet.Pictures.Paste
 
    With Pic
        .Copy
        .Delete
    End With
Set graf = ActiveSheet.ChartObjects.Add(1, 1, Selection.Width + 2, Selection.Height + 2).Chart
'Klasör ve Dosyaadı başlangıç metni
StrKlasor = "C:\Resim\":                           uznKlsr = Len(StrKlasor)
Strmetin = ThisWorkbook.Name:                      uznMtn = Len(Strmetin)
'Dizindeki dosyalar..
Set Dosyalar = CreateObject("Scripting.FileSystemObject").GetFolder(StrKlasor).Files
say = CreateObject("Scripting.FileSystemObject").GetFolder(StrKlasor).Files.Count
 
    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$(3 - Len(s), "0") & s + 1 & ".jpg"
            .Parent.Delete
        End With
 
Son:
End Sub

tekrar teşekkürler sn. anameos ve sn seyitdiken

bu kod önceden çalışıyordu şimdi

    With Pic
        .Copy
        .Delete
    End With

dizesinin copğy satırında hata veriyor neden kaynaklıdır.

 

[hsayar]

güncel yardım edebilirmisiniz seçilmesi gereken bir referans falan varmıydı?