… websites, die unsere marketing fritzen zu recherchzwecken anhäufen die Bilder herausholen. Bisher mach ich das manuell, aber ich werd verrückt damit. Daher will ich den unten angefügten code verwenden. ABER es fehlen noch zwei ZUSATZBEDINGUNGEN, denn auf praktisch allen sites sind kleine logos, banner oder so, daher muss ich eine mindestgröße z.b. 100 kb und mindestabmessungen z.B. 100x100 einbauen, von denen ich nicht weiss wie man die in vba formuliert. Hat da jemand eine gute idee für mich?
Option Explicit
Sub grafik_transfer
Dim objFSO As FileSystemObject
Dim objSourceFolder1 As Folder, objSourceFolder2 As Folder
Dim objDestFolder As Folder
Dim objFile As File
Dim strSF1 As String
Dim strDestFolder As String
Application.ScreenUpdating = False
Application.EnableEvents = False
strSF1 = fncBrowseForFolder
strDestFolder = recherchen\Bilder
Set objFSO = New FileSystemObject
Set objFolder = objFSO.GetFolderstrSF1
If > 0 Then GoTo NoFolders
For Each objSourceFolder2 In objSourceFolder1
For Each objFile In objSourceFolder2.Files
If InStr1, objFile.Name, .jpg InStr1, objFile.Name, .gif InStr1, objFile.Name, .png Then
objFile.Copy strDestFolder & \ & objFile.Name
End If
Next objFile
Next objSourceFolder2
Set objFile = Nothing: Set objFSO = Nothing: Set objSourceFolder1 = Nothing: Set objSourceFolder2 = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
NoFolders:
If objSourceFolder1.Files.Count > 0 Then
For Each objFile In objSourceFolder2.Files
If InStr1, objFile.Name, .jpg InStr1, objFile.Name, .gif InStr1, objFile.Name, .png Then
objFile.Copy strDestFolder & \ & objFile.Name
End If
Next objFile
Set objFile = Nothing: Set objFSO = Nothing: Set objSourceFolder1 = Nothing: Set objSourceFolder2 = Nothing
Application.ScreenUpdating = True 'turn screenupdating back on
Application.EnableEvents = True 'turn events back on
Exit Sub
End If
Set objFile = Nothing: Set objFSO = Nothing: Set objSourceFolder1 = Nothing: Set objSourceFolder2 = Nothing
Application.ScreenUpdating = True 'turn screenupdating back on
Application.EnableEvents = True 'turn events back on
End Sub
Private Function fncBrowseForFolderOptional ByVal defaultPath = recherchen As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object
Set objShell = CreateObjectShell.Application
Set objFlder = objShell.BrowseForFolder0&, Ordner auswählen…, 0&, defaultPath
If objFlder Is Nothing Then GoTo ErrExit
Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path
ErrExit:
Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function