Açıklama'ya makro ile Resim Almak

[1Al2Ver]

Merhaba,

Ek'li dosyada Modül1'de kayıtlı makro ile ;

"ANA_LİSTE" isimli sayfaya, "ALINACAK_ÇİZELGE" isimli sayfadaki A2:U48 aralığını, "ANA_LİSTE" G1 hücresine açıklama olarak almaya çalışıyorum,

Makro hata vermemesine rağmen "G1" e resim olarak alamadım, boş geldi.

Resim yolu, C:\RESİM olarak sürücüde kayıtlı,

Bir eksik var sanırım, yardımınızı rica ederim.

Teşekkür ederim.

 

[PLİNT]

Merhaba
Dosyanızı görme ikanım yok ama konu başlığınıza göre açıklamaya aşağıdaki kodlarla resim alabilirsiniz.

[SIZE="2"]Sub açıklamaya_resim_al()

If Not [G1].Comment Is Nothing Then [G1].Comment.Delete
With [G1]
.AddComment
.Comment.Visible = True
.Comment.Shape.Select True
End With
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 200
.ShapeRange.Width = 200
.ShapeRange.Fill.UserPicture "C:\RESİM\" &[COLOR="Blue"] [A2].Value & ".jpeg[/COLOR]"
End With
'ActiveCell.Comment.Visible = False
End Sub[/SIZE]

 

[1Al2Ver]

Sayın Plint, merhaba,

http://dosya.co/5secryqg3otr/Açıklamaya_Resim_Ekleme_(1Al2Ver)_21.09.2017.xlsm.html

Umarım doğru kopyalamışımdır.

Modül1'deki kod ;

Sub RESİM_EKLE()
On Error Resume Next

Set s2 = Sheets("ALINACAK_ÇİZELGE")
Set s1 = Sheets("ANA_LİSTE")
s2.[A2:U48].CopyPicture xlScreen, xlBitmap
ActiveSheet.Paste
genislik = Selection.Width
yukseklik = Selection.Height
Selection.Cut
Set grafik = s2.ChartObjects.Add(, , Width:=genislik, Height:=yukseklik)
grafik.Chart.Paste
grafik.Chart.Export "c:\xresimx.gif"
grafik.Delete
Set ekle = s1.[G1]
With ekle
        .ClearComments
        .AddComment
        .Comment.Text Text:="" & Chr(10) & ""
        .Comment.Shape.AutoShapeType = msoShapeRectangle
        .Comment.Shape.Fill.UserPicture "c:\xresimx.gif"

        .Comment.Visible = False
End With
    
    Range("G1").Select
        ActiveCell.Comment.Visible = True
    Range("G1").Comment.Shape.Select True
    Range("G1").Comment.Text Text:="" & Chr(10) & ""
    Selection.ShapeRange.ScaleWidth 2.31, msoFalse, msoScaleFromTopLeft   '2.69
    Selection.ShapeRange.ScaleHeight 2.31, msoFalse, msoScaleFromTopLeft '3.31
    Range("G1").Select
    ActiveCell.Comment.Visible = False
    
Kill "c:\xresimx.gif"
MsgBox "Açıklama oluşturulmuştur"

End Sub

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Sub Resim_Kaydet()
    Dim Alan As Range, S1 As Worksheet, S2 As Worksheet, XL_Chart As Chart, XL_Picture As Picture
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("ANA_LİSTE")
    Set Alan = Worksheets("ALINACAK_ÇİZELGE").Range("A2:U48")
    
    Set S2 = Worksheets.Add
    Charts.Add
    ActiveChart.Location Where:=xlLocationAsObject, Name:=S2.Name
    Set XL_Chart = ActiveChart
    Alan.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    XL_Chart.Paste
    Set XL_Picture = Selection
    
    With XL_Chart.Parent
        .Border.LineStyle = 0
        .Width = Alan.Width
        .Height = Alan.Height
    End With
    
    XL_Chart.Export Filename:=ThisWorkbook.Path & "\Resim.jpg", FilterName:="jpg"
    
    Application.DisplayAlerts = False
    S2.Delete
    Application.DisplayAlerts = True
    
    S1.Range("G1").Comment.Delete
    Set Ekle = S1.Range("G1").AddComment
    Ekle.Text Text:=""
    With Ekle.Shape
        .Fill.UserPicture ThisWorkbook.Path & "\Resim.jpg"
        .Visible = True
        .Select True
         Selection.ShapeRange.ScaleWidth 2.25, msoFalse, msoScaleFromTopLeft
         Selection.ShapeRange.ScaleHeight 2.25, msoFalse, msoScaleFromTopLeft
        .Visible = False
    End With
        
    Kill ThisWorkbook.Path & "\Resim.jpg"
    Application.ScreenUpdating = True
    
    MsgBox "Açıklama oluşturulmuştur."
End Sub

 

[1Al2Ver]

Sayın Korhan Ayhan merhaba,

Öncelikle çözüm ve ilginiz için teşekkür ederim,

Resmin boyutunu küçültmek istersem, kodda nerede düzeltme yapmam yada eklemem gerekir ?

.Width = Alan.Width + 10
        .Height = Alan.Height + 10

Buradaki sayıları değiştirip denedim ama sanırım buradan olmuyor,

Tekrar teşekkürler.

 

[1Al2Ver]

Merhaba,

Resmin boyutunu küçültmek istersem, kodda nerede düzeltme yapmam yada eklemem gerekir ?

Çözümü rica ediyorum,

Teşekkür ederim.

 

[Korhan Ayhan]

Üstteki mesajımda ki kodu güncelledim.

Deneyiniz.

 

[1Al2Ver]

Sayın Korhan Ayhan merhaba,

Teşekkür ederim, her şey için.

Saygılarımla.