Butonla fotoğraf eklemek hk. yardım

[Mahmut ŞAHİN]

Arkadaşlar butonla fotoğraf eklemek için hazır yapılmış makro buldum. Fotoğrafı seçilen hücreye sığdırarak ekliyor lakin başka bilgisayarda açınca ya da fotoğraf bilgisayardan silinince buradaki fotoğraf da siliniyor. Mümkünse bu makroyu fotoğraf silinmeyecek şekilde güncelleyebilirseniz çok sevinirim. Teşekkürler.

 

[tahsinanarat]

Aktif olan hücre boyutuna göre resim ekler

Sub seçilen_hücreye_resim_ekle()
    Dim sPicture As String, pic As Picture
    Dim Target As Range

    ChDir ThisWorkbook.Path

    sPicture = Application.GetOpenFilename _
    ("Pictures (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
    , "Select Picture to Import")

    If sPicture = "False" Then Exit Sub

    Set pic = ActiveSheet.Pictures.Insert(sPicture)
 
    With pic
        .ShapeRange.LockAspectRatio = msoFalse
        .Height = ActiveCell.Offset(0, 0).MergeArea.Height
        .Width = ActiveCell.Offset(0, 0).MergeArea.Width
        .Top = ActiveCell.Top
        .Left = ActiveCell.Left
        .Placement = xlMoveAndSize
    End With

    Set pic = Nothing
End Sub

 

[Mahmut ŞAHİN]

Aktif olan hücre boyutuna göre resim ekler

Sub seçilen_hücreye_resim_ekle()
    Dim sPicture As String, pic As Picture
    Dim Target As Range

    ChDir ThisWorkbook.Path

    sPicture = Application.GetOpenFilename _
    ("Pictures (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
    , "Select Picture to Import")

    If sPicture = "False" Then Exit Sub

    Set pic = ActiveSheet.Pictures.Insert(sPicture)

    With pic
        .ShapeRange.LockAspectRatio = msoFalse
        .Height = ActiveCell.Offset(0, 0).MergeArea.Height
        .Width = ActiveCell.Offset(0, 0).MergeArea.Width
        .Top = ActiveCell.Top
        .Left = ActiveCell.Left
        .Placement = xlMoveAndSize
    End With

    Set pic = Nothing
End Sub

Çok teşekkür ederim. Elinize sağlık.

 

[yektamollaoglu]

merhabalar.fotograflar kücük görünüyor.acaba nasil büyütebilirim?tesekkürler

 

[Muzaffer Ali]

merhabalar.fotograflar kücük görünüyor.acaba nasil büyütebilirim?tesekkürler

Aşağıdaki satırlarda fotoğrafların boyutları hücre boyutu ile aynı yapılıyor.
Silerseniz orijinal boyutta olur.

        .Height = ActiveCell.Offset(0, 0).MergeArea.Height
        .Width = ActiveCell.Offset(0, 0).MergeArea.Width

Yada istediğiniz boyutta yapabilirsiniz. Rakamları büyük yada küçük yazarak aşağıdaki gibi istediğiniz boyutta yapın.

        .Height = 20
        .Width =30