resim uzantısı çoklu seçim olabilir mi?

[euphrates55]

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim resim As Object, i As Long, yol As String, dosya As String
Sheets("Sunu").Select
yol = ThisWorkbook.Path & "\haritalar\"

Rem aralıktaki resmi sil
Set alan = Range("k15:s15")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, alan) Is Nothing Then
resimm.Delete
End If
Next
Set alan = Nothing
Rem silme işleminin sonu

If Dir(yol & "\" & Cells(1, "V").Value & ".png") <> "" Then
dosya = "\" & Cells(1, "V").Value & ".png"
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(15, "k")
t = .Top
l = .Left
W = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.Top = t + 1
.Left = l + 1
.Width = W - 1
.Height = h - 1
End With
Set P = Nothing
End If

If Dir(yol & "\" & Cells(1, "V").Value & ".png") <> "" Then dosya = "\" & Cells(1, "V").Value & ".png"
kısmında resim isim aynı olmak şartı ile uzantının ne olduğu farketmeden resim çağırtabilir miyim? bazen uzantıları farklı resimler koyabiliyorum sonra farkına varıp uzantı için düzeltme yapmak durumunda kalıyorum

 

[halit3]

Bu kodu bir dene

Private Sub Worksheet_Change(ByVal Target As Range)

Dim s1
Set s1 = Sheets(ActiveSheet.Name)
If InStr(Trim(ActiveWindow.RangeSelection.Address), ":") = 0 Then

Dim Picture As Object

Set Adres = Range("k15:s15")
For Each Picture In ActiveSheet.Pictures
If Not Intersect(Picture.TopLeftCell, Adres) Is Nothing Then
Picture.Delete
End If
Next
Set Adres = Nothing


ReDim uzanti(11)
uzanti(1) = "bmp":        uzanti(2) = "jpg"
uzanti(3) = "gif":        uzanti(4) = "pcx"
uzanti(5) = "tga":        uzanti(6) = "emf"
uzanti(7) = "abm":        uzanti(7) = "avi"
uzanti(8) = "png":        uzanti(9) = "jpeg"
uzanti(10) = "wmf":       uzanti(11) = "TIFF"

For j = 1 To 11

Dosya2 = ThisWorkbook.Path & "\haritalar\" & Cells(1, "V").Value & "." & uzanti(Val(j))
If CreateObject("Scripting.FileSystemObject").FileExists(Dosya2) = True Then
dosya = Dosya2
Exit For
End If
Next

If CreateObject("Scripting.FileSystemObject").FileExists(Dosya2) = True Then
dosya = Dosya2
Else
GoTo atla
End If

Set Adres2 = Cells(15, "k")

If CreateObject("Scripting.FileSystemObject").FileExists(dosya) = True Then
ad = s1.Pictures.Insert(dosya).Name
s1.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(ad).OLEFormat.Object.Top = Adres2.Top + 1
s1.Shapes(ad).OLEFormat.Object.Left = Adres2.Left + 1
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres2.Height - 2
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres2.Width - 2

End If
atla:


End If
End Sub

 

[halit3]

2 nolu mesajdaki kodu güncelledim

 

[euphrates55]

2 nolu mesajdaki kodu güncelledim

teşekkürler. kod komple değişmiş öbürüne alışmıştım aslında, başka yerlerde de kullanabiliyordum. bu bayağı ağır geldi bana. adapte etmeye çalışacağım.