Soru Makro İle İstenilen Hücre Aralığına Resim Almak

[ormann]

İyi günler;
Ekli örnek dosyada veri sayfasında ki resim al butonu ile göstereceğimiz dosya yolunda ki resmi B7:N25 hücre aralığına aldırabilir miyiz. Yardımcı olur musunuz .

İndir örnek

Dosyayı indir örnek

dosya.co

 

[cicosz]

Merhaba,

Deneyiniz.
https://www.dosya.tc/server30/yxkuxa/revornek.xlsm.html

 

[ormann]

Merhaba,

Deneyiniz.
https://www.dosya.tc/server30/yxkuxa/revornek.xlsm.html

Sayın cicosz çok teşekkür ederim. Tam istediğim şekilde oluyor. Sizden ricam makroyu resim al butonu farklı sayfada olduğu zaman resmi butonun olduğu sayfaya alıyor.Benim istediğim buton hangi sayfada olursa oldun resim yine veri sayfasına alınabilir mi?.Ayrıca korumalı sayfaya resmi aldırabilir miyiz ?

 

[cicosz]

Deneyiniz.
https://s7.dosya.tc/server17/4po963/rev01ornek.xlsm.html

 

[ormann]

Sayfa adı "VERİ " sayfası olarak yaptığımızda bu sayfaya resmi alabilir miyiz.Sadece kodu ekleme yapar sanız ben uyarlarım.Saygılar

 

[cicosz]

Butonu nereye koyarsanız koyun fotoğraf eklemesini “Veri” sayfasına yapar. (#4 nolu mesaj)

 

[ormann]

Ben örneğin resmi veri sayfası degilde yeni eklemiş olduğum sayfaya almasını istiyorum.Örnegin resim sayfası buraya alabilirmiyim.Makro da sayfa adını değiştirdiğim zaman buraya alınsa.Örnegın,
Sheets("Resim") şeklinde .Kod böyle olabilir mi?

 

[cicosz]

Kod bölümünde sheets(1) olan kısımları sheets(“sayfaAdı”) yaparsanız olur.

 

[ormann]

Hocam aldığımız dosyanın adını da T15 hücresine aldırmak mümkün mü?

 

[ormann]

Hocam makroda sayfa adını değiştirdiğim zaman resmi almıyor.Hatalı işlem yapıldı uyarısı veriyor.Ayrıca dosyanın adını da T15 hücresine aldırmak mümkün mü?

Sub ResimEkle()
Dim eskizoom As Integer
eskizoom = ActiveWindow.Zoom
On Error GoTo hata
Dosya = Application.GetOpenFilename(FileFilter:="," & _
        "*.jpeg;*.png;*.bmp;*.jpg;*.gif", _
        Title:="Resim seçimi yapınız")
    If Dosya = False Then
    MsgBox "Resim seçmediniz.", vbInformation, "DİKKAT"
    Exit Sub
    Else
    End If
    Application.ScreenUpdating = False
    ActiveWindow.Zoom = 100
    oncekisayfa = ActiveSheet.Name
    Sheets("RESİM").Activate
Set Alan = Range("B7:N25")
    For Each Resim In Sheets(1).Pictures
    If Not Intersect(Resim.TopLeftCell, Alan) Is Nothing Then
    Resim.Delete
    End If
    Next
    Set Alan = Nothing

    Cells(7, "B").Select
    Set Adres = Range(ActiveWindow.RangeSelection.Address)
    Sheets(1).Shapes.AddPicture(Filename:=Dosya, linktofile:=msoFalse, _
            savewithdocument:=msoCTrue, Left:=0, Top:=0, Width:=-1, Height:=-1).Select
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = Adres.Height * 0.96
    Selection.ShapeRange.Width = Adres.Width * 0.97
    Selection.Top = Adres.Top + (Adres.Height - Selection.ShapeRange.Height) / 2
    Selection.Left = Adres.Left + (Adres.Width - Selection.ShapeRange.Width) / 2
        ActiveWindow.Zoom = eskizoom
    Sheets(oncekisayfa).Activate
    Application.ScreenUpdating = True
    Exit Sub
hata:
    MsgBox "Hatalı İşlem Yapıldı.", vbCritical, "UYARI"
    
End Sub

 

[cicosz]

#8 nolu mesajı dikkatli okuyup uygulamaya çalışınız. İyi çalışmalar.

 

[ormann]

#8 nolu mesajı dikkatli okuyup uygulamaya çalışınız. İyi çalışmalar.

Sayın cicosz çok teşekkür ederim.Uyguladım oldu.Acaba resim dosyasının adını da T15 hücresine aynı makro ile aldırabilir miyiz?