DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Private Sub CommandButton1_Click()
On Error Resume Next
Dim Picture As Object
deg = 0
For Each Picture In Sheets("Sayfa1").Shapes
If TypeName(Sheets("Sayfa1").Shapes(Picture.Name).OLEFormat.Object) = "OLEObject" Then
If TypeName(Sheets("Sayfa1").Shapes(Picture.Name).OLEFormat.Object.Object) = "Image" Then
If Picture.Name = "Image1" Then
deg = 1
End If
End If
End If
Next Picture
If deg = 0 Then
Dim Obj As Object
Dim Cell As Range
Set Cell = Cells(2, "b")
Set Obj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1")
With Obj
.Left = Cell.Left
.Top = Cell.Top
.Height = Cell.Height
.Width = Cell.Width
.PrintObject = False
End With
End If
Sheets("Sayfa1").Image1.Picture = LoadPicture(None)
resimyükle = ComboBox1.Text
For Each Picture In Sheets("Sayfa1").Shapes
If TypeName(Sheets("Sayfa1").Shapes(Picture.Name).OLEFormat.Object) = "OLEObject" Then
If TypeName(Sheets("Sayfa1").Shapes(Picture.Name).OLEFormat.Object.Object) = "Image" Then
If Picture.Name = "Image1" Then
Sheets("Sayfa1").Shapes(Picture.Name).OLEFormat.Object.Object.Picture = LoadPicture(resimyükle)
End If
End If
End If
Next Picture
End Sub
bu kodu denermisiniz.
Merhaba.
Image1'in nerede olduğunu belirtmemişsiniz..!
Aşağıdaki link işinize yarayabilir.
http://www.excel.web.tr/f48/smi-kriter-alarak-resim-caoyrma-t87053.html
Halit Hocam ilginiz içn teşekkür ederim.
If olan satırlarda hata veriyor.
bunun içine yazdığımız zaman bazı kelimelerin aralarında boşluklar oluyor.
Kod:bunun içine yazdığımızda olmuyor 3 . nolu mesajdaki kodu düzelttim.
Konunun takpçisiydim elinize sağlık halit bey güzel sonuçlandı.
Bende buna benzer bir işlem yapacaktım çok işime yarayacak.
Halit hocam işlem tamam ancak, ımage üzerine gelen resmin küçük bir kısmı hücreye atılıyor. Resmin orijinal halini atmak için ne yapmamız gerekiyor.
Halit Hocam tamam sorunu hallettim teşekkür ederim.