Resim getir Kod çalışmıyor

[Ergün GÖKER]

Değerli hocalarım herkese kolay gelsin. Bir çalışmamda kullanmak üzere Resim getirmek istiyorum. Command butona bastığımda Resim dosyası açılıyor , buradan istediğim resmi JPEG formatında seçtiğim zaman ( ! geçersiz resim dosyası hatası alıyorum) Bu resmi belirleyeceğim bir alana örneğin D22:BY58 hücreleri arasına getirmek istiyorum. Makroyu düzeltmeme yardımcı olurmusunuz. Şimdiden teşekkürler

Private Sub CommandButton11_Click() 'resim getirme
Dim Filtre As FileDialogFilters
On Error GoTo Catch
With Application.FileDialog(MsoFileDialogType.msoFileDialogOpen)
Set Filtre = .Filters
With Filtre
.Clear
.Add "Resimler", "*.bmp,*.jpg,*.gif"
End With
.AllowMultiSelect = False
If .Show = False Then Exit Sub
Image1.Picture = LoadPicture(.SelectedItems(1))
End With
Exit Sub
Catch:
Call MsgBox("Geçersiz Resim Dosyası", vbExclamation)
End Sub

 

[PLİNT]

With Filtre
.Clear
.Add "Resimler", "*.bmp,*.jpg,*.gif"
End With
.AllowMultiSelect = False
If .Show = False Then Exit Sub
Image1.Picture = LoadPicture(.SelectedItems(1))
End With
Exit Sub
Catch:
Call MsgBox("Geçersiz Resim Dosyası", vbExclamation)
End Sub

Merhaba
Sizin kodlarınızdaki hata sayfada "Image1" nesnesi olmadığından çıkıyordur,
istediğiniz aralığa eklerseniz sorun kalmaz (ama adına dikkat) ediniz.
nesne kulanmadan yapmak istiyorsanız aşağıdaki gibi olabilir.

Private Sub [COLOR="Red"]CommandButton11[/COLOR]_Click()
Dim Filtre As FileDialogFilters
Dim x As Shape
Dim Catch
For Each x In ActiveSheet.Shapes
If Not Intersect(x.TopLeftCell, Range("D20:BY59")) Is Nothing Then _
x.Delete
Next
On Error GoTo Catch
With Application.FileDialog(MsoFileDialogType.msoFileDialogOpen)
Set Filtre = .Filters
With Filtre
.Clear
.Add "Resimler", "*.bmp,*.jpg,*.jpeg,*.gif"
End With
.AllowMultiSelect = False
If .Show = False Then Exit Sub
Range("D22").Select
Application.ScreenUpdating = False
ActiveSheet.Pictures.Insert(.SelectedItems(1)).Select
With Selection.ShapeRange
.LockAspectRatio = msoFalse
.Width = 3549.9
.Height = 557
End With
Application.ScreenUpdating = True
End With
Exit Sub
Catch:
Call MsgBox("Geçersiz Resim Dosyası", vbExclamation)
End Sub

 

[mydestek]

resim ekleme

http://www.excel.web.tr/f48/excel-resim-ekleme-hak-t154539.html#post841033 inceler misiniz.

 

[Ergün GÖKER]

PLİNT HOCAM öncelikle verdiğiniz kod için teşekkür ederim. Lakin istediğim aralığa resmi sığdıramıyorum. ayrıca yeni resim getirdiğinde bir öncekini silebebilecek bir kod varmıdır. Şimdiden teşekkürler

 

[PLİNT]

Merhaba
Yukarıdaki 2 nolu mesajımdaki kodlara ek yapmaya çalıştım denermisiniz?

 

[Ergün GÖKER]

PLİNT Hocam evet istediğim gibi oldu teşekkür ederim. Tam aradığım kod. Ellerinize sağlık. Saygılarımla

 

[PLİNT]

PLİNT Hocam evet istediğim gibi oldu teşekkür ederim. Tam aradığım kod. Ellerinize sağlık. Saygılarımla

Rica ederim, kolay gelsin.