Soru Kapalı klasörden JPG,JPEG,PNG uzantılı dosyaları çağırma

#1
merhaba,

aşağıdaki kodda sadece JPG olan resimleri çağırıyor..
" JPEG , PNG " türlerinide aynı kodda düzenleyip çağırmak istiyorum..genelde klasörlerde jpg oluyor aamma arada gözden kaçanlar oluyor.jpeg gibi..onları JPG olmadığı için çagıırdığımda gelmiyor.

nereye nasıl ekleme yapabilirim...


Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [a1:c65536]) Is Nothing Then Exit Sub
If Target.Row Mod 3060 = 0 Then Exit Sub
On Error GoTo hata
For i = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(i).Left = Target.Offset(2, 0).Left _
And ActiveSheet.Shapes(i).Top = Target.Offset(2, 0).Top Then
ActiveSheet.Shapes(i).Delete
End If
Next i
hata:
On Error GoTo son
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(2, 0).Top
Selection.Left = Target.Offset(2, 0).Left
Selection.ShapeRange.IncrementLeft 520
Selection.ShapeRange.IncrementTop 113
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 163
Selection.ShapeRange.Width = 331
Target.Select
son:
End Sub

'Sub Album_Resim_Sil()
'Dim sekiL As Shape
'For Each sekiL In ActiveSheet.Shapes
'If Not Intersect(sekiL.TopLeftCell, Range("a1:c65000")) Is Nothing Then
' sekiL.Delete
'End If
' Next
'End Sub
 

alperduryaz

New member
Üye
#2
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".jpg").Select olan satıra dosyanın var olup olmadığını yazan kodu yazarsak jpg yoksa jped o da yoksa png yi arar.

Kod:
If Not Dir(ThisWorkbook.Path & "\" & Target.Value & ".jpg") = "" Then
  ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".jpg").Select

ElseIf Not Dir(ThisWorkbook.Path & "\" & Target.Value & ".jpeg") = "" Then
  ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".jpeg").Select

ElseIf Not Dir(ThisWorkbook.Path & "\" & Target.Value & ".png") = "" Then
  ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".png").Select

Else
  MsgBox "dosya yok"
  Exit Sub
End If
 
Üst