Makro ile çekilen fotoyu hücreye ortalamak

[kneehot]

Arkadaşlar merhaba, elimde aşağıdaki kod var fakat resmi tanımlı hücrenin soluna yaslıyor. Hücreyi ortalayacak şekilde güncellemek istiyorum. Yardımlarınız için şimdiden teşekkürler.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
Dim p As Object, t As Double, l As Double, w As Double, h As Double

ResimDosya = "C:\Foto" & "\" & Target.Value & ".jpg"
'ResimDosya = "C:\Foto" & "\" & Target.Offset(0, 1).Value & ".jpg"
If Dir(ResimDosya) = "" Then Exit Sub
Set p = ActiveSheet.Pictures.Insert(ResimDosya)

With Cells(Target.Row, Target.Column - 1)
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With

With p
.Top = t
.Left = l
.Width = w
.Height = h
End With

Set p = Nothing

End Sub

 

[Muzaffer Ali]

Merhaba.

        p.Top = .Top + 3 'hücrenin üst kısmından 3 birim aşağı kaydırır
        p.Left = .Left + 3 'hücrenin sol kısmından 3 birim sağa kaydırır

Aşağıdaki kodda da açıklama yaptım. Aşağıdaki kodu kullanın

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
    Dim p As Object, t As Double, l As Double, w As Double, h As Double
    ResimDosya = "C:\Foto" & "\" & Target.Value & ".jpg"
    If Dir(ResimDosya) = "" Then Exit Sub
    Set p = ActiveSheet.Pictures.Insert(ResimDosya)
    
    With Cells(Target.Row, Target.Column - 1)
        p.Top = .Top + 3 'hücrenin üst kısmından 3 birim aşağı kaydırır
        p.Left = .Left + 3 'hücrenin sol kısmından 3 birim sağa kaydırır
        p.Width = .Offset(0, .Columns.Count).Left - .Left
        p.Height = .Offset(.Rows.Count, 0).Top - .Top
    End With
End Sub

 

[kneehot]

Merhaba.

        p.Top = .Top + 3 'hücrenin üst kısmından 3 birim aşağı kaydırır
        p.Left = .Left + 3 'hücrenin sol kısmından 3 birim sağa kaydırır

Aşağıdaki kodda da açıklama yaptım. Aşağıdaki kodu kullanın

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
    Dim p As Object, t As Double, l As Double, w As Double, h As Double
    ResimDosya = "C:\Foto" & "\" & Target.Value & ".jpg"
    If Dir(ResimDosya) = "" Then Exit Sub
    Set p = ActiveSheet.Pictures.Insert(ResimDosya)
   
    With Cells(Target.Row, Target.Column - 1)
        p.Top = .Top + 3 'hücrenin üst kısmından 3 birim aşağı kaydırır
        p.Left = .Left + 3 'hücrenin sol kısmından 3 birim sağa kaydırır
        p.Width = .Offset(0, .Columns.Count).Left - .Left
        p.Height = .Offset(.Rows.Count, 0).Top - .Top
    End With
End Sub

Çok teşekkürler, bir konuda daha yardımınızı isteyebilir miyim? Sadece jpg uzantılı dosyaları okuyor hem jpg hem de png dosyalarını okuyabilecek şekilde kodlanabilir mi?

 

[kneehot]

Merhaba, bu kodu ekleyebilecek yardımsever bir arkadaş varmıdır

 

[YUSUF44]

Şöyle dener misiniz?

ResimDosya = "C:\Foto" & "\" & Target.Value & ".jpg"
If Dir(ResimDosya) = "" Then
    ResimDosya = "C:\Foto" & "\" & Target.Value & ".png"
End If
If Dir(ResimDosya) = "" Then Exit Sub