Option Explicit
'by Ramses
'Deklaration für Folderdialog < Office XP
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
'Deklarataion für Wartezyklen
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Excel_Slide_Show()
'by Ramses
'Angezeigt werden Bilder mit dem Format
'jpg, bmp, gif
'Die Zeit zur Darstellung kann in A1 eingetragen werden
'Alternativ werden die Bilder alle 5 Sekunden gewechselt
Dim oldStatus As Variant, myPic As Object
Dim srchFolder As String, gefFile As String
Dim i As Integer, totFiles As Integer, sleepTime As Integer
Dim noFile1 As Boolean, noFile2 As Boolean, noFile3 As Boolean
'SleepTime in Millisekunden = Wie lange das Bild angezeigt wird
sleepTime = 5000
srchFolder = GetDirectory("Wählen Sie den Ordner mit den Bildern aus")
If srchFolder = "" Then
MsgBox "Kein Ordner gewählt", vbInformation + vbOKOnly, "Abbruch"
Exit Sub
End If
'Application.ScreenUpdating = False
oldStatus = Application.DisplayStatusBar
With Application.FileSearch
.LookIn = srchFolder
.SearchSubFolders = False
.Filename = "*.bmp"
If .Execute() > 0 Then
totFiles = .FoundFiles.Count
Application.StatusBar = "BMP Bild " & i & " von " & totFiles & " wird angezeigt"
For i = 1 To .FoundFiles.Count
gefFile = .FoundFiles(i)
Set myPic = ActiveSheet.Pictures.Insert(gefFile)
With myPic
.TopLeftCell = Range("b5")
End With
If Range("A1") = "" Then
'5 Sekunden warten
Sleep sleepTime
Else
Application.Wait Now + TimeSerial(0, 0, Range("A1"))
End If
myPic.Delete
Next i
Else
noFile1 = True
End If
End With
With Application.FileSearch
.LookIn = srchFolder
.SearchSubFolders = False
.Filename = "*.gif"
If .Execute() > 0 Then
totFiles = .FoundFiles.Count
Application.StatusBar = "GIF Bild" & i & " von " & totFiles & " wird angezeigt"
For i = 1 To .FoundFiles.Count
gefFile = .FoundFiles(i)
Set myPic = ActiveSheet.Pictures.Insert(gefFile)
With myPic
.TopLeftCell = Range("b5")
End With
If Range("A1") = "" Then
'5 Sekunden warten
Sleep sleepTime
Else
Application.Wait Now + TimeSerial(0, 0, Range("A1"))
End If
myPic.Delete
Next i
Else
noFile2 = True
End If
End With
With Application.FileSearch
.LookIn = srchFolder
.SearchSubFolders = False
.Filename = "*.jpg"
If .Execute() > 0 Then
totFiles = .FoundFiles.Count
Application.StatusBar = "Bild " & i & " von " & totFiles & " wird angezeigt"
For i = 1 To .FoundFiles.Count
gefFile = .FoundFiles(i)
Set myPic = ActiveSheet.Pictures.Insert(gefFile)
With myPic
.TopLeftCell = Range("b5")
End With
If Range("A1") = "" Then
Sleep sleepTime
Else
Application.Wait Now + TimeSerial(0, 0, Range("A1"))
End If
myPic.Delete
Next i
Else
noFile3 = True
End If
End With
If noFile1 = True And noFile2 = True And noFile3 = True Then
MsgBox "Keine Bilder zum anzeigen gefunden", vbInformation + vbOKOnly, "Sorry,..."
Else
MsgBox "Keine weiteren Bilder zum anzeigen gefunden", vbInformation + vbOKOnly, "Slide Show Ende"
End If
Application.StatusBar = oldStatus
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
End Sub