• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Ekran Resmi Alma

H

hamza02

Katılım
24 Mart 2021
Mesajlar
70
Excel Vers. ve Dili
Türkçe

İndir Günlük İcmal xlsm

Dosyayı indir Günlük İcmal xlsm
dosya.co

Arkadaşlar merhaba,
Bu dosyamda iki adet ekran resmi alma butonu var.
Birincisinde sayfa içine kaydediyor, sorun yok.
İkinci butonda masaüstüne kaydediyor ancak sadece kenar çizgileri olan boş bir resim oluşturuyor.

Yapmak istediğim, ikinci butonun birinci buton gibi belirtilen hücre aralığının resmini alması ve dosya adına mevcut tarih ve saati yazması.
Şimdiden teşekkürler.
 
Kod: 
Private Sub CommandButton2_Click()
    Dim jipeg As Range
    Dim caartObj As ChartObject
    Dim masaustu As String
    Dim timestamp As String
    Dim dosyaYolu As String
    
    masaustu = CreateObject("WScript.Shell").specialfolders("Desktop")
    timestamp = Format(Now, "yyyy-mm-dd_hh-mm-ss")
    dosyaYolu = masaustu & "\screenshot_" & timestamp & ".jpg"
    
    Set jipeg = ActiveSheet.Range("A1:F23")
    jipeg.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    
    Set caartObj = ActiveSheet.ChartObjects.Add(Left:=jipeg.Left, Top:=jipeg.Top, _
                                              Width:=jipeg.Width, Height:=jipeg.Height)
    
    With caartObj
        .Select
        .Chart.Paste
        
        DoEvents
        .Chart.Export Filename:=dosyaYolu, FilterName:="JPG"
        
        .Delete
    End With
    
    Set jipeg = Nothing
    Set caartObj = Nothing
    
End Sub

Buton2 kodunu silip bunu kullanınız
 
Sayın muhasebeciyiz hocam elinize emeğinize sağlık, çok güzel olmuş, çok teşekkür ederim.
 
Hocam ekran resmi almayı bir kaç ayrı dosyada kullanıyorum. Bu dosyalarda çalışırken excel'in sağ alt köşedeki ekran büyütme küçültme yüzdeliği % 80 le % 100 arasında değişiyor çalışma sayfasına göre, ama ekran resmi alırken resmin daha net olması için bu yüzdeliği artırıyorum. Ekran resmi aldıktan sonra tekrar küçültüyorum.
Bu işlemi kodlara ekleyebilir misiniz.
Örneğin % 80 ile çalıştığım sayfanın ekran resmini % 130 büyüterek versin ve sonra tekrar % 80 yapsın.
Veya resim boyutlandırma ile boyut artırırsak aynı işlem olur mu?
 
Hocam birde ekran resmi aldığım hücreler renkli olduğu için daha önce farketmedim şimdi renksiz hücreler ekleyince farkettim resme dış çerçeve çizgisi oluşturuyor, bu çizgiyi eklememesini nasıl sağlarız.
 
Kod: 
Private Sub CommandButton2_Click()
    Dim jipeg As Range
    Dim caartObj As ChartObject
    Dim masaustu As String
    Dim timestamp As String
    Dim dosyaYolu As String
    Dim eskiBorders() As Variant
    Dim i As Long   
    
    masaustu = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    timestamp = Format(Now, "yyyy-mm-dd_hh-mm-ss")
    dosyaYolu = masaustu & "\screenshot_" & timestamp & ".jpg"   
    
    Set jipeg = ActiveSheet.Range("A1:F23")   
    
    ReDim eskiBorders(1 To jipeg.Borders.Count)
    For i = 1 To jipeg.Borders.Count
        eskiBorders(i) = jipeg.Borders(i).LineStyle
        jipeg.Borders(i).LineStyle = xlNone   ' Kenarlıkları geçici kaldır
    Next i   
    
    jipeg.CopyPicture Appearance:=xlScreen, Format:=xlPicture   
    
    Set caartObj = ActiveSheet.ChartObjects.Add(Left:=jipeg.Left, Top:=jipeg.Top, _
                                                Width:=jipeg.Width, Height:=jipeg.Height)
    With caartObj
        .Chart.Paste
        DoEvents
        .Chart.Export Filename:=dosyaYolu, FilterName:="JPG"
        .Delete
    End With   
    
    For i = 1 To jipeg.Borders.Count
        jipeg.Borders(i).LineStyle = eskiBorders(i)
    Next i   
    
    Set jipeg = Nothing
    Set caartObj = Nothing
    
    MsgBox "Ekran görüntüsü başarıyla kaydedildi:" & vbCrLf & dosyaYolu, vbInformation
End Sub

Denermisiniz
 
Kod: 
Private Sub CommandButton2_Click()
    Dim jipeg As Range
    Dim caartObj As ChartObject
    Dim masaustu As String
    Dim timestamp As String
    Dim dosyaYolu As String
    Dim eskiBorders() As Variant
    Dim i As Long
   
    masaustu = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    timestamp = Format(Now, "yyyy-mm-dd_hh-mm-ss")
    dosyaYolu = masaustu & "\screenshot_" & timestamp & ".jpg"
   
    Set jipeg = ActiveSheet.Range("A1:F23")
       
    ReDim eskiBorders(1 To jipeg.Borders.Count)
    For i = 1 To jipeg.Borders.Count
        eskiBorders(i) = jipeg.Borders(i).LineStyle
        jipeg.Borders(i).LineStyle = xlNone
    Next i
   
   
    jipeg.CopyPicture Appearance:=xlScreen, Format:=xlPicture
   
   
    Set caartObj = ActiveSheet.ChartObjects.Add(Left:=jipeg.Left, Top:=jipeg.Top, _
                                                Width:=jipeg.Width, Height:=jipeg.Height)
   
    With caartObj
        .ShapeRange.Line.Visible = msoFalse
        .ShapeRange.Fill.Visible = msoFalse
       
        .Activate
        .Chart.Paste
       
       
        DoEvents
        Application.Wait (Now + TimeValue("0:00:01"))
        DoEvents
       
        .Chart.Export Filename:=dosyaYolu, FilterName:="JPG"
        .Delete
    End With
   
   
    For i = 1 To jipeg.Borders.Count
        jipeg.Borders(i).LineStyle = eskiBorders(i)
    Next i
   
   
    Set jipeg = Nothing
    Set caartObj = Nothing
   
    MsgBox "Ekran görüntüsü başarıyla kaydedildi:" & vbCrLf & dosyaYolu, vbInformation
End Sub

son paylaştığımı deneyin lütfen
 
Hocam denedim, resme dış çerçeve çizgisi vermiyor ancak tablo içindeki tüm kenarlık çizgilerini kaldırıyor.
 
Kod: 
Private Sub CommandButton2_Click()
    Dim jipeg As Range
    Dim caartObj As ChartObject
    Dim masaustu As String
    Dim timestamp As String
    Dim dosyaYolu As String
    Dim eskiBorders As Object
    Dim kenarlikIndex As Variant
    
    masaustu = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    timestamp = Format(Now, "yyyy-mm-dd_hh-mm-ss")
    dosyaYolu = masaustu & "\screenshot_" & timestamp & ".jpg"
    
    Set jipeg = ActiveSheet.Range("A1:F23")
    
    Set eskiBorders = CreateObject("Scripting.Dictionary")
    For Each kenarlikIndex In Array(xlInsideVertical, xlInsideHorizontal)
        eskiBorders(kenarlikIndex) = jipeg.Borders(kenarlikIndex).LineStyle
        jipeg.Borders(kenarlikIndex).LineStyle = xlNone
    Next kenarlikIndex
    
    jipeg.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    
    Set caartObj = ActiveSheet.ChartObjects.Add(Left:=jipeg.Left, Top:=jipeg.Top, _
                                                Width:=jipeg.Width, Height:=jipeg.Height)
  
    With caartObj
        .ShapeRange.Line.Visible = msoTrue
        .ShapeRange.Line.ForeColor.RGB = RGB(0, 0, 0)
        .ShapeRange.Line.Weight = 2
        .ShapeRange.Fill.Visible = msoFalse
      
        .Activate
        .Chart.Paste      
        
        DoEvents
        Application.Wait (Now + TimeValue("0:00:01"))
        DoEvents      
        
        .Chart.Export Filename:=dosyaYolu, FilterName:="JPG"
        .Delete
    End With
    
    For Each kenarlikIndex In Array(xlInsideVertical, xlInsideHorizontal)
        jipeg.Borders(kenarlikIndex).LineStyle = eskiBorders(kenarlikIndex)
    Next kenarlikIndex
  
    Set jipeg = Nothing
    Set caartObj = Nothing
    Set eskiBorders = Nothing
  
    MsgBox "Ekran görüntüsü başarıyla kaydedildi:" & vbCrLf & dosyaYolu, vbInformation
End Sub

Deneyiniz
 
Hocam denedim, hem oluşturulan ekran resminde kenar çizgileri yok, hem de mevcut excel dosyasındaki kenarlık çizgilerini kaldırıyor.
 
Alternatif...

C++: 
Private Sub CommandButton2_Click()
    Dim Rng As Range, X_Picture As Object, Old_Zoom_Rate As Integer
    
    Old_Zoom_Rate = ActiveWindow.Zoom
    
    ActiveWindow.Zoom = 130
    
    Set Rng = Range("B2:F24")
    
    With Rng
        .CopyPicture xlScreen, xlBitmap
        ActiveSheet.Paste
        Selection.Cut
        Set X_Picture = ActiveSheet.ChartObjects.Add(Left:=0, Top:=0, Width:=.Width, Height:=.Height)
        With X_Picture
            .Activate
            .Chart.Paste
            .Chart.ChartArea.Format.Line.Visible = msoFalse
            .Chart.Export CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Test.jpg"
            .Delete
        End With
    End With
    
    ActiveWindow.Zoom = Old_Zoom_Rate
    
    Set X_Picture = Nothing
    Set Rng = Nothing
    
    MsgBox "Resim kayıt edilmiştir."
End Sub
 
Sayın Korhan Ayhan hocam,

Elinize emeğinize sağlık, çok güzel olmuş, çok teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst