Resim ekleme ve boyutlandırma

[tamer42]

Merhaba,
Aşağıdaki kod ile hücreye küçük resim ekliyorum, eklenen görseli ilgili hücrenin satır yüksekliğine göre boyutlandırıyor.
Yalnız eklenen görselin yatay boyutu, dikey boyutuna göre çok fazla olduğu zaman (ekli resim); bu sefer resim yatayda hücreyi taşıyor.

Resmi boyutlandırırken görselin eni hücrenin genişliğine gelince boyutlandırmayı bitirsin.

Özetle boyutlandırma esnasında dikey yada yatayda hangisi hücrenin boyutuna önce gelirse, boyutlandırma sonlandırılsın, görsel yatay veya dikeyde hücreyi aşmasın.

Teşekkürler,
iyi akşamlar.

Sub TestInsertPictureInRange()
    InsertPictureInRange "C:\Users\xxxxxx\Pictures\yyyyy\zzzzzz\L-123.jpg", _
        Range("E15")
End Sub

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(PictureFileName) = "" Then Exit Sub
    ' import picture
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
    ' determine positions
    
    With TargetCells
        t = .Top
        l = .Left
        w = .Offset(0, .Columns.Count).Left - .Left
        h = .Offset(.Rows.Count, 0).Top - .Top
    End With
    ' position picture
    
    With p
        .Top = t
        .Left = l
        .Width = w
        .Height = h
    End With
    
    Set p = Nothing
End Sub

 

[EmrExcel16]

Merhaba , aşağıdaki kodlar ile resmi hücre boyutlarıyla aynı yapabilirsiniz.

Sub Hucre_Resim_Ekle()
    Dim sPicture As String, pic As Picture, Hucre As Range
    sPicture = "C:\Users\xxxxxx\Pictures\yyyyy\zzzzzz\L-123.jpg"
    Set Hucre = Range("E15")
    If sPicture = "False" Then Exit Sub
    Set pic = ActiveSheet.Pictures.Insert(sPicture)
   
    With pic
        .ShapeRange.LockAspectRatio = msoFalse
        .Height = Hucre.Offset(0, 0).MergeArea.Height - 0.2
        .Width = Hucre.Offset(0, 0).MergeArea.Width - 0.2
        .Top = Hucre.Top + 0.2
        .Left = Hucre.Left + 0.2
        .Placement = xlMoveAndSize
    End With
   
    Set pic = Nothing
End Sub

 

[Haluk]

Merhaba , aşağıdaki kodlar ile resmi hücre boyutlarıyla aynı yapabilirsiniz.

Emre Bey; eğer eklenecek resmin en/boy oranı hücrenin en/boy oranına eşit değilse, o zaman sayfaya eklenen resmin görüntüsü orantısız olur....

Neyse, soruyu soran Tamer bey konuyu değerlendirecektir... belki de kodunuz onun işini görüyordur.

.

 

[tamer42]

Sn

Merhaba , aşağıdaki kodlar ile resmi hücre boyutlarıyla aynı yapabilirsiniz.

Sub Hucre_Resim_Ekle()
    Dim sPicture As String, pic As Picture, Hucre As Range
    sPicture = "C:\Users\xxxxxx\Pictures\yyyyy\zzzzzz\L-123.jpg"
    Set Hucre = Range("E15")
    If sPicture = "False" Then Exit Sub
    Set pic = ActiveSheet.Pictures.Insert(sPicture)
  
    With pic
        .ShapeRange.LockAspectRatio = msoFalse
        .Height = Hucre.Offset(0, 0).MergeArea.Height - 0.2
        .Width = Hucre.Offset(0, 0).MergeArea.Width - 0.2
        .Top = Hucre.Top + 0.2
        .Left = Hucre.Left + 0.2
        .Placement = xlMoveAndSize
    End With
  
    Set pic = Nothing
End Sub

Sn Emre ilginize teşekkürler,
benim sıkıntım görselin hücre ile aynı boyutta olması değil, yatayda ve dikeyde hücreyi taşmasın yeter, hücre içinde yatay veya dikey' in bir tarafında boşluk kalabilir.

diğer durumda görseli eşit boyutlandırmıyor. görsel bozuluyor.

iyi akşamlar dilerim.

 

[EmrExcel16]

Sn


Sn Emre ilginize teşekkürler,
benim sıkıntım görselin hücre ile aynı boyutta olması değil, yatayda ve dikeyde hücreyi taşmasın yeter, hücre içinde yatay veya dikey' in bir tarafında boşluk kalabilir.

diğer durumda görseli eşit boyutlandırmıyor. görsel bozuluyor.

iyi akşamlar dilerim.

Rica ederim , ben yanlış yorumladım olayı , yardımcı olamadım kusura bakmayın. Belki Haluk hocam yardımcı olur bu konuda.

 

[Haluk]

Tam olarak test etmedim ama, ekli dosyayı bir deneyin .... belki işe yarayabilir.

.

 

[tamer42]

Tam olarak test etmedim ama, ekli dosyayı bir deneyin .... belki işe yarayabilir.

.

Haluk hocam çok teşekkürler,
tam istediğim gibi..