- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,853
- Excel Vers. ve Dili
-
2003 excell türkçe
ve
2007 excell türkçe
Excel Dosyasındaki Resimleri Çıkarma bu kod ile kısaca şu işlem yapılmakta Açılan pencereden bir excel dosyasını seçip sonra farklı kaydet seçeneklerinden htm uzantılı kayıt yapıp sonra bu kayıtta ki resimleri dosyanın hemen yanına Resimler klasörü oluşturup içine resim dosyalarını aktarmakta kod bunları otomatik yapıyor.
Kod:
Sub Dasyadaki_resimleri_çıkart()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject")
aranan_Uzanti = fs.GetExtensionName(Application.AddIns.Item(1).FullName)
uzanti = fs.GetExtensionName(ThisWorkbook.Name)
If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then
uzanti1 = "DosyalarExcel Files (*.xls,*.xlsx,*.xlsm,*.xlsb)|*.xls;*.xls;*.xlsm;*.xlsb"
Else
End If
End If
If aranan_Uzanti = "xla" Then
If uzanti = "xls" Then
uzanti1 = "DosyalarExcel Files (.xls)|*.xls"
Else
End If
End If
Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Dim objDialog, intResult
Set objDialog = CreateObject("MSComDlg.CommonDialog")
objDialog.flags = 4
objDialog.Filter = uzanti1 '"DosyalarExcel Files (.xls)|*.xls"
objDialog.FilterIndex = 1
objDialog.InitDir = ThisWorkbook.Path
objDialog.ShowOpen
intResul = objDialog.Filename
Dosya = intResul
If fL.GetFileName(intResul) = ThisWorkbook.Name Or Mid(fL.GetFileName(intResul), 1, 2) = "~$" Then
MsgBox "Bu dosya kendi dosyası işlem yapılamaz.", vbInformation + vbCritical
Exit Sub
End If
If Len(intResul) = 0 Then
MsgBox "Dosya seçmediniz.", vbInformation + vbCritical
Exit Sub
Else
End If
dosya_adi = fL.GetBaseName(Dosya)
'On Error Resume Next
Klasor = fL.GetParentFolderName(Dosya)
If Right(Klasor, 1) <> "\" Then Klasor = Klasor & "\"
Hedef = ThisWorkbook.Path & "\Resimler"
If fL.FolderExists(Hedef) = False Then
MkDir Hedef
End If
Dim wb As Workbook
Set wb = Workbooks.Open(Dosya)
ActiveWorkbook.SaveAs Filename:=Klasor & dosya_adi & ".htm" _
, FileFormat:=xlHtml, ReadOnlyRecommended:=False, CreateBackup:=False
wb.Close
For Each dosya2 In fL.GetFolder(Klasor & dosya_adi & "_dosyalar").Files
uzanti = LCase(fL.GetExtensionName(dosya2))
If uzanti = "jpg" Or uzanti = "gif" Or uzanti = "png" Then
eski = dosya2
Say = fL.GetFolder(Hedef).Files.Count + 1
yeni = Hedef & "\Resim" & Say & "." & uzanti
FileCopy eski, yeni
End If
Next
fL.DeleteFile Klasor & "\" & dosya_adi & ".htm", True
fL.DeleteFolder Klasor & dosya_adi & "_dosyalar", True
Set objDialog = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "İşlem Tamam"
End Sub
