[Beschreibung] · [Programm-Listing] · [Download des Skripts]
| Beschreibung |
Gelegentlich hat man verschiedene Garfikdateien auf der Festplatte, einem Netzlaufwerk oder einem Server des firmeninternen Intranets. Wenn man ein bestimmtes Bild sucht, ohne ein geeignetes Bildbetrachtungsprogramm zu besitzen (kommt auf Firmenrechnern häufiger vor, weil soclhe Werkzeuge nicht vom Adiministrator genehmigt oder lizensiert wurden), muss man jede Datei einzeln öffnen, um die Bilder anzusehen. Dsa folgende Programm erstellt eine HTML-Datei, welche alle Bilder eines Verzeichnisses zeigt. Die Grafikformate müssen allerdings vom Internet-Explorer darstellbar sein, sonst werden die Dateien von diesem VBS ignoriert. Der Internet-Explorer stellt diese Grafikformate dar: JPEG, GIF, PNG, BMP oder TIFF. Wichtig: Das Skript erstellt keine Thumbnails. Dies hat zwar einerseits den Vorteil, dass es (außer der HTML-Datei) keine zusätzlichen Dateien erzeugt, heißt aber andererseits, dass der Browser das Bild in voller Größe lädt und es dann für die Anzeige anpaßt. Dadurch muss das ganze Bild in voller Dateigröße geladen werden, weshalb sich dieses Skript nicht für Seiten im Internet eignet. Das Skript basiert auf dem bereits beschriebenen rekurisven Skript zur Suche im Dateisystem. Es kann auf mehrere Arten aufgerufen werden:
Das Skript schlägt dann einen Dateinamen für die Index-Datei vor, wobei die Datei standardmäßig unter dem Namen index.html im gleichen Verzeichnis wie die Bilder gespeichert wird. Das Skript durchsucht keine Unterverzeichnisse. |
| Programm-Listing |
Die grünen Texte im unten angegebenen Quellcode sind Kommentare, die bei der Eingabe ausgelassen werden können. |
Option Explicit
On Error Resume Next
Const TabSpalten = 3
Const BildBreite = 100
Const SeitenTitel = "Bildgalerie"
Const BildQuelle = "Internet"
Dim FS, Liste, Nr, Verzeichnis, Objekt
Dim AusgabeDatei, DateiName, BildDateiTypen, SpalteNr
Set Liste = WScript.Arguments
Set FS = CreateObject("Scripting.FileSystemObject")
' Dateiendungen, die als Grafiken angezeigt werden sollen
BildDateiTypen = array(".JPG", ".JPEG", ".GIF", ".PNG", ".TIF", ".TIFF", ".BMP")
SpalteNr = 1
If Liste.Count > 0 Then
' Then wird ausgeführt, wenn aus dem Explorer Dateien
' mit Drag & Drop auf diese Skript-Datei gezogen wurden
DateiErstellen Liste(0)
For Nr = 0 To Liste.Count - 1
DateiSystemDurchsuchen Liste(Nr)
Next
Else
' Else wird ausgeführt, wenn dieses Skript gestartet
' wurde, ohne dass Argumente übergeben wurden
' Ruft einen Dialog von Windows auf, mit dem eine
' Datei oder ein Ordner ausgewählt werden kann
Set Verzeichnis = CreateObject("Shell.Application") _
.BrowseForFolder(0, "Datei oder Verzeichnis wählen" _
, &H4011, 17)
' Skript beenden, falls im Dialog die Schaltfläche
' Abbrechen gedrückt wurde
If TypeName(Verzeichnis) = "Nothing" Then WScript.Quit
Objekt = LCase(TypeName(Verzeichnis.ParentFolder))
If (Objekt LIKE "folder*") Then
For Each Objekt In Verzeichnis.ParentFolder.Items
If Objekt.Name = Verzeichnis.Title Then Exit For
Next
End If
DateiErstellen Objekt.Path
DateiSystemDurchsuchen Objekt.Path
End If
' Ende der Ausgabedatei schreiben
With AusgabeDatei
If Nr Mod 3 = 0 Then AusgabeDatei.WriteLine "</TR>"
.WriteLine "</TABLE>"
.WriteLine "</BODY></HTML>"
.Close
End With
' Ausgabedatei öffnen
' CreateObject("WScript.Shell").Run DateiName, True
'*** Ende des Skripts
Private Sub DateiErstellen(AusgabePfad)
Dim MeldungsText
On Error Resume Next
MeldungsText = "AusgabeDatei wählen"
DateiName = FS.GetDriveName(AusgabePfad)
DateiName = FS.GetFolder(AusgabePfad).Path
DateiName = FS.GetFile(AusgabePfad).ParentFolder
DateiName = DateiName & "\index.html"
Do
DateiName = InputBox(MeldungsText, "Bildgalerie erstellen", DateiName)
If DateiName = "" Then WScript.Quit
MeldungsText = "Ausgabedatei existiert. Bitte neuen Namen wählen"
Loop While FS.FileExists(DateiName)
Set AusgabeDatei = FS.CreateTextFile(DateiName, True)
' Dateikopf schreiben
With AusgabeDatei
.WriteLine "<HTML><HEAD>"
.WriteLine "<STYLE TYPE=""text/css"">"
.WriteLine " H1 {font-family:helvetica,sans-serif}"
.WriteLine " P, CAPTION, BODY {font-family:verdana,helvetica,sans-serif;font-size:8pt}"
.WriteLine "</STYLE>"
.WriteLine "<TITLE>" & SeitenTitel & "</TITLE>" ' Titelleitse
.WriteLine "</HEAD><BODY>"
.WriteLine "<H1 ALIGN=CENTER>" & SeitenTitel & "</H1>" ' Überschrift
.WriteLine "<P ALIGN=CENTER>Quelle: " & BildQuelle
.WriteLine "<TABLE BORDER=0 CELLPADDING=10 CELLSPACING=0 ALIGN=CENTER>"
.WriteLine "<CAPTION ALIGN=BOTTOM>Zum Vergrößern der Bilder klicken.<BR>So werden die Bilder auf die Festplatte kopiert:<BR>Mauszeiger über das Bild, rechte Maustaste klicken, 'Bild speichern unter ...' wählen.</CAPTION>"
End With
End Sub
' *** Ende des Scripts
' ---------------------------------------------------------- '
' Rekursives Unterprogramm um das Dateisystem zu durchsuchen
' ---------------------------------------------------------- '
Private Sub DateiSystemDurchsuchen(Pfad)
Dim Ordner, UnterOrdner, Datei
If FS.FolderExists(Pfad) Then
' Then: Falls Ordner übergeben wurde
Set Ordner = FS.GetFolder(Pfad)
' Papierkorb nicht bearbeiten
If LCase(Ordner.Name) = "recycled" Then Exit Sub
' Funktion Bearbeiten() für Ordner aufrufen
If Not Bearbeiten(Ordner, False) Then Exit Sub
' Alle Dateien im Ordner bearbeiten
For Each Datei In Ordner.Files
' Prozedur Bearbeiten() für Dateien aufrufen
If Not Bearbeiten(Datei, True) Then Exit For
Next
ElseIf FS.FileExists(Pfad) Then
' Else: Falls eine einzelne Datei übergeben wurde
Bearbeiten FS.GetFile(Pfad), True
End If
End Sub
' Funktion, die den Inhalt der Ausgabe bestimmt
Private Function Bearbeiten(Datei, IstDatei)
Dim Ext, BildPfad
Bearbeiten = True
If IstDatei Then
For Each Ext In BildDateiTypen
If UCase(Right(Datei.Name, Len(Ext))) = Ext Then
If SpalteNr Mod TabSpalten = 1 Then AusgabeDatei.WriteLine "<TR VALIGN=MIDDLE>"
BildPfad = RelativerPfad(DateiName, Datei.Path)
AusgabeDatei.WriteLine "<TD><P ALIGN=CENTER><A HREF=""" & BildPfad & """ TARGET=""_BLANK""><IMG SRC=""" & BildPfad & """ ALT=""" & Datei.Name & """ ALIGN=CENTER WIDTH=" & BildBreite & " BORDER=0></A></TD>"
If SpalteNr Mod TabSpalten = 0 Then AusgabeDatei.WriteLine "</TR>"
SpalteNr = SpalteNr + 1
Exit Function
End If
Next
End If
End Function
Private Function RelativerPfad(ByVal Pfad, ByVal LinkAuf)
Dim Pos
Pfad = Replace(Pfad, "\", "/")
LinkAuf = Replace(LinkAuf, "\", "/")
Do
Pos = InStr(1, LinkAuf, "/")
If UCase(Mid(Pfad, 1, Pos)) <> UCase(Mid(LinkAuf, 1, Pos)) Then Exit Do
Pfad = Mid(Pfad, Pos + 1)
LinkAuf = Mid(LinkAuf, Pos + 1)
Loop Until Pos = 0
Pos = InStr(1, Pfad, "/")
While Pos <> 0
LinkAuf = "../" & LinkAuf
Pos = InStr(Pos + 1, Pfad, "/")
Wend
RelativerPfad = Replace(LinkAuf, " ", "%20")
End Function
|