Resim Ekleme (birleştirilmiş hücre içerisine)

[Leturc]

İyi günler,

Daha önceden sizlerin yardımları ile yapmış olduğum bir makroyu yeniden düzenleme ihtiyacı duymaktayım. Aşağıda yer alan makro ile seçmiş olduğum hücre içerisine resim eklemekte herhangi bir sorun yaşamıyorum. Ancak birleştirilmiş hücre (merged cell) içerisine eklemek istediğimde sol üstte yer alan ilk hücreye göre kendini ayarlıyor. Acaba bunu nasıl düzeltebilirim. İkinci olarak ise bu makroyu resimleri oryantasyonuna (dikey ya da yatay) göre eklemek üzere ayarlamıştık. Dikey resimlerde resmi hücreye sığdırıp ortalıyor ancak yatay resimlerde eğer resimler 16/9 formatında ise resimleri yalnızca en olarak sığdırıyor ancak ortalamıyor hücreye.


Ekte verdiğim belgeyi incelemeniz durumunda çok daha net anlaşılacağını tahmin ediyorum.

Teşekkürler

Sub InsertionImage()

Dim Emplacement As Range
Dim Img As Variant
Dim XRatio As Double
Dim YRatio As Double

If Application.Dialogs(xlDialogInsertPicture).Show Then
Set Emplacement = ActiveCell
Set Img = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)

XRatio = ActiveCell.Width / Img.Width
YRatio = ActiveCell.Height / Img.Height

With Img
.ShapeRange.LockAspectRatio = msoFalse
.Left = ActiveCell.Left + 1
.Top = ActiveCell.Top + 1
.Placement = xlMoveAndSize
End With

If (XRatio < YRatio) Then
Img.Width = (Img.Width * XRatio) - 1
Img.Height = (Img.Height * XRatio) - 1
Else
Img.Width = (Img.Width * YRatio) - 1
Img.Height = (Img.Height * YRatio) - 1
End If

If (Img.Width < ActiveCell.Width) Then
Img.Left = ActiveCell.Left + 1 + ((ActiveCell.Width - Img.Width) / 2)
End If


End If
End Sub

 

[Necdet]

Merhaba,

2003 sürüm xl de resmin hücreye tam olarak ayarlanabilmesinde bende sorun yaşamıştım.
ama aynı dosyayı 2007 de denediğimde o sorunla karşılaşmadım.

 

[Leturc]

ben her ikisinde de bu kod ile herhangi bir sorun yaşamıyorum sadece yeni özellikler ekleme peşindeyim

 

[Necdet]

Merhaba,

Aşağıdaki şekilde dener misiniz? Ben başarılı oldum denemelerimde. (Sürüm 2007 ile)

Sub InsertionImage()
    Dim Emplacement As Range
    Dim Img As Variant
    Dim XRatio As Double
    Dim YRatio As Double
    [COLOR=red]Dim adr     As String
[/COLOR]    
    [COLOR=red]adr = Selection.Address
[/COLOR]    
    If Application.Dialogs(xlDialogInsertPicture).Show Then
        Set Emplacement = ActiveCell
        Set Img = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)
        
        XRatio =[COLOR=red] Range(adr)[/COLOR].Width / Img.Width
        YRatio = [COLOR=red]Range(adr)[/COLOR].Height / Img.Height
        
        With Img
            .ShapeRange.LockAspectRatio = msoFalse
            .Left = ActiveCell.Left + 1
            .Top = ActiveCell.Top + 1
            .Placement = xlMoveAndSize
        End With
        
        If (XRatio < YRatio) Then
            Img.Width = (Img.Width * XRatio) - 1
            Img.Height = (Img.Height * XRatio) - 1
        Else
            Img.Width = (Img.Width * YRatio) - 1
            Img.Height = (Img.Height * YRatio) - 1
        End If
        
        If (Img.Width <[COLOR=red] Range(adr)[/COLOR].Width) Then
             Img.Left = Range(adr).Left + 1 + (([COLOR=red]Range(adr)[/COLOR].Width - Img.Width) / 2)
        End If
    End If
End Sub

 

[Leturc]

elinize sağlık hocam, inan şu an yüzümde kocamaaaan bir gülümse var.

Yalnız ortalama için de yardımcı olabilecek misiniz?

 

[Necdet]

Merhaba,

Bazıları gözden kaçmış olabilir aceleden, Activecell gördüğünüz her yeri Range(adr) deyip deniyin isterseniz.

 

[Leturc]

Merhaba,

Bazıları gözden kaçmış olabilir aceleden, Activecell gördüğünüz her yeri Range(adr) deyip deniyin isterseniz.

Hocam düzelttim ancak yine de hücreye ortalamıyor