KLASÖRDEN HÜCREYE RESİM ÇEKME

[avare1907]

Değerli üstad'lar bir konuda desteğinizi rica edeceğim eklediğim bir form var sizden ricam formun başındaki açılır listedeki kırmızı renk ile işaretlediğim parça hücredeki parçanın resmi masaüstündeki kalsörden resim hücresine gelsin ve hücre boyutuna göre olsun hücre boyutunu sonra kendim ayarlayacağım,

desteğiniz için şimdiden teşekkürlerimi sunuyorum saygılarımla.

 

[mustafakayali]

Sana kendi yaptığım programı atayım mı? DRİVE LİNKİ Burada kurulum mevcut yapmak istediğin excel dosyasını seçiyorsun. Sonra resim klasörünü seçiyorsun. Sonra Excelin içindeki hangi sütun ile senin resim isimlerin eşleşiyor onu seçiyorsun sonra da resimleri hangi sütuna eklemek istiyorsun onu seçiyorsun. Genişlik ve yüksekliği de ayarlamak istersen ayarlarsın. anlamadığın bir yer olursa tekrar yazarsın

 

[muratgunay48]

Bir modüle yapıştırın. Seçili hücreye resim eklemek için makroyu çalıştırın.
Ancak seçtiğiniz resim ve hücrenin en boy oranı eşit olmalı. Yoksa görsel açıdan güzel gözükmez.
Kolay gelsin.

Option Explicit
Sub resimekle()

Dim sPicture As String, pic As Picture
Dim Target As Range
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

 

[Hakan ERDOST]

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim resimAdi As String
    Dim resimYolu As String
    Dim eklenenResim As Object
    Dim hedefHücre As Range
    Dim birlesikAlan As Range
   
    ' Değişiklik M4 hücresinde mi oldu?
    If Not Intersect(Target, Me.Range("M4")) Is Nothing Then
        ' Eski resmi kaldır
        On Error Resume Next
        Me.Pictures.Delete
        On Error GoTo 0
       
        ' Resim adını al
        resimAdi = Me.Range("M4").Value
       
        ' Resim yolunu oluştur
        resimYolu = Environ("USERPROFILE") & "\Desktop\Deneme\" & resimAdi & ".png"
       
        ' Hedef hücreyi tanımla (birleştirilmiş hücre)
        Set hedefHücre = Me.Range("A13")
        Set birlesikAlan = hedefHücre.MergeArea ' Birleştirilmiş alan
       
        ' Eğer resim varsa ekle
        On Error Resume Next
        Set eklenenResim = Me.Pictures.Insert(resimYolu)
        On Error GoTo 0
       
        If Not eklenenResim Is Nothing Then
            With eklenenResim
                ' Resmin sol üst köşesini birleştirilmiş hücrenin sol üst köşesine hizala
                .Left = birlesikAlan.Left
                .Top = birlesikAlan.Top
                ' Resmi birleştirilmiş hücrenin boyutlarına göre ayarla
                .Width = birlesikAlan.Width
                .Height = birlesikAlan.Height
                .Placement = xlMoveAndSize ' Resmin hücreyle hareket etmesini ve boyutlanmasını sağlar
            End With
        Else
            MsgBox "Resim bulunamadı: " & resimYolu, vbExclamation
        End If
    End If
End Sub

Kodu VBA açarak sol taraftaki 1. OP. adlı çalışma sayfasına çift tıklayarak açılan kod modülüne yapıştırın. Klasörün yolu ve resim uzantınızı (jpg vb) kendinize göre uyarlayınız.

 

[avare1907]

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim resimAdi As String
    Dim resimYolu As String
    Dim eklenenResim As Object
    Dim hedefHücre As Range
    Dim birlesikAlan As Range
  
    ' Değişiklik M4 hücresinde mi oldu?
    If Not Intersect(Target, Me.Range("M4")) Is Nothing Then
        ' Eski resmi kaldır
        On Error Resume Next
        Me.Pictures.Delete
        On Error GoTo 0
      
        ' Resim adını al
        resimAdi = Me.Range("M4").Value
      
        ' Resim yolunu oluştur
        resimYolu = Environ("USERPROFILE") & "\Desktop\Deneme\" & resimAdi & ".png"
      
        ' Hedef hücreyi tanımla (birleştirilmiş hücre)
        Set hedefHücre = Me.Range("A13")
        Set birlesikAlan = hedefHücre.MergeArea ' Birleştirilmiş alan
      
        ' Eğer resim varsa ekle
        On Error Resume Next
        Set eklenenResim = Me.Pictures.Insert(resimYolu)
        On Error GoTo 0
      
        If Not eklenenResim Is Nothing Then
            With eklenenResim
                ' Resmin sol üst köşesini birleştirilmiş hücrenin sol üst köşesine hizala
                .Left = birlesikAlan.Left
                .Top = birlesikAlan.Top
                ' Resmi birleştirilmiş hücrenin boyutlarına göre ayarla
                .Width = birlesikAlan.Width
                .Height = birlesikAlan.Height
                .Placement = xlMoveAndSize ' Resmin hücreyle hareket etmesini ve boyutlanmasını sağlar
            End With
        Else
            MsgBox "Resim bulunamadı: " & resimYolu, vbExclamation
        End If
    End If
End Sub

Kodu VBA açarak sol taraftaki 1. OP. adlı çalışma sayfasına çift tıklayarak açılan kod modülüne yapıştırın. Klasörün yolu ve resim uzantınızı (jpg vb) kendinize göre uyarlayınız.

öncelikle talebimi dikkate alıp yardımcı olmaya çalışan herkese teşekkürlerimi sunuyorum,

üstad ben kodu yapıştırdığımda bir hata yapıyorum sanırım daha doğrusu resmi çekeceği klasörün yolunu yanlış yeremi yapıştırıyorum aşağıdaki gibi bir hata veriyor henüz başarılı olamadım aydınlatırsan çok memnun olurum saygılarımla,

 

[Hakan ERDOST]

Evet dosya yolunuz yanlış.

 resimYolu = Environ("USERPROFILE") & "\Desktop\Deneme\" & resimAdi & ".png"

Burada değişiklik yapacaksınız.