Dieser Workshop zeigt wie man mit reinen VB-Boardmitteln Vorschaubilder (Thumbnails) von Grafiken in einer bestimmten Größe erstellen kann. Außerdem lernen Sie, wie sich die Größe einer Grafik ermitteln lässt, wie man Grafiken zoomen und dann als neues Bild abspeichern kann. Am Ende des Workshops wartet dann eine kleine Anwendung, welche für alle Grafikdateien eines Verzeichnisses die entsprechenden Vorschaubilder erstellt und in ein neues Verzeichnis abspeichert - und das sogar optional als JPEGs mit einstellbarer Bildqualität. Einführendes Beispiel Das nachfolgende Beispiel zeigt, wie man von bestehenden Bildern eine kleine Vorschau-Grafik (Thumbnails) erstellen kann. Hierzu wird das Originalbild zunächst in eine PictureBox geladen. Mittels PaintPicture wird das Bild dann verkleinert in eine zweite PictureBox kopiert, und kann dann mit dem Befehl SavePicture als Bitmap-Bild abgespeichert werden. Erstellen Sie ein neues Projekt und plazieren auf der Form1 zwei PictureBoxen. Erstellen Sie die 2. PictureBox bereits in der Größe, in der die Vorschau-Datei angezeigt werden soll. Fügen Sie über das Menü Projekte - Komponenten das "Microsoft Common Dialog-Steuerelement" hinzu und plazieren eine Instanz auf das Formular. Jetzt wird noch ein CommandButton benötigt, über welchen das Original-Bild ausgewählt werden soll (Command1) und ein weiterer (Command2), über welchen das Vorschau-Bild gespeichert werden kann. Und hier der Code: ' Originalbild per Dialog auswählen Private Sub Command1_Click() Dim sFilename As String Dim sExt As String On Local Error Resume Next With CommonDialog1 .CancelError = True .Filter = "alle Bilddateien|*.jpg;*.gif;*.bmp" .ShowOpen If Err.Number = 0 Then ' Thumbnail erstellen Picture1.Picture = LoadPicture(.Filename) If Err.Number = 0 Then CreateThumbnail Picture1, Picture2 ' Vorschlag für neuen Dateinamen sFilename = Left$(.FileName, _ InStrRev(.FileName, ".") - 1) sExt = Mid$(.FileName, _ InStrRev(.FileName, ".") + 1) Picture1.Tag = sFilename + "-small.bmp" Else ' Fehler beim Laden des Bildes MsgBox "Fehler beim Laden des Bildes." End If Else ' Abbrechen wurde gewählt End If End With End Sub ' Vorschau-Grafik (Thumbnail) erstellen Private Sub CreateThumbnail(Pic1 As PictureBox, _ Pic2 As PictureBox) With Pic2 .AutoRedraw = True .Cls .PaintPicture Pic1.Picture, 0, 0, .Width, .Height, _ 0, 0, Pic1.Width, Pic1.Height End With End Sub ' Thumbnail speichern Private Sub Command2_Click() ' Vorschau-Bild als BMP speichern On Local Error Resume Next With CommonDialog1 .CancelError = True .DialogTitle = "Vorschau speichern" .Filter = "Bitmap-Bild (*.bmp)|*.bmp" .FileName = Picture1.Tag .ShowSave If Err.Number = 0 Then SavePicture Picture2.Image, .FileName End If End With End Sub Wichtig! Nachteil Größe des Orginalbildes ermitteln Mit einem kleinen Trick - ganz ohne Verwendung des Windows-API - lässt sich die Größe des Originalbildes ganz leicht ermitteln. Fügen Sie der Form zusätzlich noch ein Image-Objekt hinzu und setzen Visible auf False. Wie Sie ja sicherlich wissen, passt sich das Image-Objekt im Gegensatz zum Picture-Objekt der Größe des Bildes an - zumindest immer dann, wenn Stretch auf False gesetzt ist. Also verwenden Sie doch einfach diese "schöne" Eigenschaft, um die tatsächliche Bildgröße des Originalbildes zu ermitteln.' Größe des Orginalbildes ermitteln Private Sub GetImageSize(ByVal sImageFile As String, _ nWidth As Long, nHeight As Long) On Local Error Resume Next nWidth = 0: nHeight = 0 With Image1 .Picture = LoadPicture(sImageFile) If Err.Number = 0 Then nWidth = .Width nHeight = .Height End If .Picture = LoadPicture() End With End Sub Die Prozedur GetImageSize gibt nun in den Parametern nWidth und nHeight die Breite und Höhe des durch sImageFile angegebenen Bildes zurück. Konnte das Bild nicht geladen werden, so wird für nWidth und nHeight der Wert 0 gesetzt. Neuer Code ' Originalbild per Dialog auswählen Private Sub Command1_Click() Dim nWidth As Long Dim nHeight As Long Dim sFilename As String Dim sExt As String On Local Error Resume Next With CommonDialog1 .CancelError = True .Filter = "alle Bilddateien|*.jpg;*.gif;*.bmp" .ShowOpen If Err.Number = 0 Then ' Bildgröße ermitteln GetImageSize .FileName, nWidth, nHeight If nWidth > 0 And nHeight > 0 Then ' Größe der Picturebox für die Anzeige des ' Originalbildes anpassen Picture1.Width = nWidth Picture1.Height = nHeight Picture1.Picture = LoadPicture(.FileName) ' Thumbnail erstellen CreateThumbnail Picture1, Picture2 ' Vorschlag für neuen Dateinamen sFilename = Left$(.FileName, _ InStrRev(.FileName, ".") - 1) sExt = Mid$(.FileName, _ InStrRev(.FileName, ".") + 1) Picture1.Tag = sFilename + "-small.bmp" Else ' Fehler beim Laden des Bildes MsgBox "Fehler beim Laden des Bildes." End If Else ' Abbrechen wurde gewählt End If End With End Sub Steigerung: Grafik vergrößern/verkleinern Eine weitere Steigerung wäre, wenn sich für das Vorschaubild nicht nur eine fixe Größe, sondern eine prozentuale Verkleinerung einstellen liesse, z.B. 50% kleiner. Kein Problem: Beim Verwenden der PaintPicture-Methode lässt sich u.a. die Größe des Zielbildes angeben, so daß sich eine Zoomfunktion leicht realisieren lässt. Ändern Sie einfach die CreateThumbnail-Prozedur entsprechend ab, so daß sich optional der Zoomfaktor als Parameter übergeben lässt. Grafik zoomen (verkleinern/vergrößern) ' Vorschau-Grafik (Thumbnail) erstellen Private Sub CreateThumbnail(Pic1 As PictureBox, _ Pic2 As PictureBox, _ Optional ByVal Zoom As Integer = 0) Dim NewWidth As Long Dim NewHeight As Long With Pic2 .AutoRedraw = True .Cls ' wenn Zoomfaktor angegeben If Zoom <> 0 Then With Pic1 If Zoom < 0 Then ' verkleinern NewWidth = .Width - (.Width / 100 * Abs(Zoom)) NewHeight = .Height - (.Height / 100 * Abs(Zoom)) Else ' vergrößern NewWidth = .Width + (.Width / 100 * Zoom) NewHeight = .Height + (.Height / 100 * Zoom) End If End With ' Größe der Picturebox setzen .Width = NewWidth .Height = NewHeight End If .PaintPicture Pic1.Picture, 0, 0, .Width, .Height, _ 0, 0, Pic1.Width, Pic1.Height End With End Sub Soll also das geladene Bild z.B. um 50% vekleinert dargestellt werden, so setzen Sie folgenden Prozeduraufruf ein: Private Sub Command1_Click() ... ' 50% verkleiner CreateThumbnail Picture1, Picture2, -50 ... End Sub Um das Vorschaubild vergrößert darzustellen, muss als Parameter ein positiver Wert eingesetzt werden: Private Sub Command1_Click() ... ' 65% vergrößern CreateThumbnail Picture1, Picture2, 65 ... End Sub Abschluss-Projekt Autom. Thumbnails aller Bilder eines Verzeichnisses erstellen Das Programm selbst besteht hierbei nur aus einem Dialogfenster, in welchem Sie den Ordner der Orginalbilder und den Ordner für die Vorschaubilder festlegen. Zusätzlich lässt sich noch angeben, ob die Vorschaubilder eine feste Größe haben sollen, oder ob eine prozentuale Verkleinerung der Orginalbilder erfolgen soll. Per OK-Button wird der Vorgang dann gestartet und das Programm wieder beendet. Das Formular Für das Formular werden folgende Steuerelemente benötigt:
Und hier der Source: Option Explicit Dim IniFile As String ' Einstellungen ermitteln Private Sub Form_Load() ' Ini-Datei, in welcher die zuletzt festgelegten ' Ordnerangaben gespeichert werden IniFile = App.Path & _ IIf(Right$(App.Path, 1) <> "\", "\", "") & _ App.EXEName & ".ini" ' Ordner-Angaben des letzten Aufrufs ermitteln Dim F As Integer Dim OrdnerQuelle As String Dim OrdnerZiel As String Dim optIndex As Integer Dim sWidth As String Dim sHeight As String Dim sZoom As String If Dir(IniFile) <> "" Then F = FreeFile Open IniFile For Input As #F Line Input #F, OrdnerQuelle Line Input #F, OrdnerZiel Line Input #F, sWidth Line Input #F, sHeight Line Input #F, sZoom Input #F, optIndex Close #F Else ' Voreinstellungen optIndex = 1 sZoom = "50" End If Option1(optIndex) = True Text1.Text = OrdnerQuelle Text2.Text = OrdnerZiel Text3.Text = sWidth Text4.Text = sHeight Text5.Text = sZoom End Sub Ordnerauswahl ' Quell-Ordner auswählen Private Sub Cmd1_Click() Dim Ordner As String Ordner = BrowseForFolder("Wählen Sie den " & _ "Ordner aus, in welchem sich die Originalbilder " & _ "befinde.") If Ordner <> "" Then Text1.Text = Ordner End Sub ' Ziel-Ordner auswählen Private Sub Cmd2_Click() Dim Ordner As String Ordner = BrowseForFolder("Wählen Sie den " & _ "Ordner aus, in welchem sich die Originalbilder " & _ "befinde.") If Ordner <> "" Then Text2.Text = Ordner End Sub Bilder ermitteln und Vorschaubilder speichern Alle Bilder des Quell-Verzeichnisses ermitteln ' Vorschaubilder (Thumbnails) erstellen Private Sub cmdOK_Click() Dim OrdnerQuelle As String Dim OrdnerZiel As String ' zunächst prüfen, ob es sich um gültige ' Ordnerangaben handelt OrdnerQuelle = Trim$(Text1.Text) OrdnerZiel = Trim$(Text2.Text) ' Ggf. abschließenden Backslash entfernen If Right$(OrdnerQuelle, 1) = "\" Then _ OrdnerQuelle = Left$(OrdnerQuelle, Len(OrdnerQuelle) - 1) If Right$(OrdnerZiel, 1) = "\" Then _ OrdnerZiel = Left$(OrdnerZiel, Len(OrdnerZiel) - 1) ' Quell-Ordner prüfen If Not FolderExists(OrdnerQuelle) Then MsgBox "Der Ordner '" & OrdnerQuelle & "' " & _ "existiert nicht. " & vbCrLf & "Bitte " & _ "prüfen Sie Ihren Angaben.", 16, "ACHTUNG!" Text1.SetFocus Exit Sub End If ' Ziel-Ordner prüfen If Not FolderExists(OrdnerZiel) Then If MsgBox("Der Ordner '" & OrdnerZiel & "' " & _ "existiert nicht." & vbCrLf & "Soll der Ordner " & _ "jetzt erstellt werden?", 36, "HINWEIS") = vbNo Then ' Ordner nicht erstellen Text2.SetFocus Exit Sub Else ' Ordner erstellen On Local Error Resume Next MkDir OrdnerZiel If Err.Number <> 0 Then MsgBox "Der Ziel-Ordner kann nicht erstellt " & _ "werden!", 16, "FEHLER" Text2.SetFocus Exit Sub End If End If End If ' Aktuelle Einstellungen speichern Dim F As Integer F = FreeFile Open IniFile For Output As #F Print #F, OrdnerQuelle Print #F, OrdnerZiel Print #F, Text3.Text Print #F, Text4.Text Print #F, Text5.Text Print #F, IIf(Option1(0) = True, 0, 1) Close #F ' Dateien ermitteln und Thumbnails speichern Dim DirName As String Dim sFilename As String Dim sExt As String Dim nWidth As Long Dim nHeight As Long ' Wenn fixe Größe eingestellt, dann Picture2 ' in der Größe entsprechend anpassen If Option1(0) Then With Picture2 .Width = Val(Text3.Text) * Screen.TwipsPerPixelX .Height = Val(Text4.Text) * Screen.TwipsPerPixelY End With End If Screen.MousePointer = 11 DirName = Dir(OrdnerQuelle & "\*.*", vbNormal) While DirName <> "" If DirName <> "." And DirName <> ".." Then ' Prüfen, ob es sich um eine Datei mit der ' Extension .BMP, .JPG, .JPEG oder .GIF handelt If InStr(DirName, ".") > 0 Then sFilename = Left$(DirName, _ InStrRev(DirName, ".") - 1) sExt = Mid$(DirName, InStrRev(DirName, ".")) Select Case UCase(sExt) Case ".BMP", ".JPG", ".JPEG", ".GIF" ' Größe des Originalbildes ermitteln ' dient gleichzeitig auch der Prüfung, ob ' das Bild geladen werden konnte GetImageSize OrdnerQuelle & "\" & DirName, _ nWidth, nHeight If nWidth > 0 And nHeight > 0 Then ' Bild konnte geladen werden! With Picture1 .Width = nWidth .Height = nHeight .Picture = LoadPicture(OrdnerQuelle & _ "\" & DirName) End With If Option1(0) Then ' Fixe Größe CreateThumbnail Picture1, Picture2 Else ' Zoom (verkleinern) CreateThumbnail Picture1, Picture2, _ -Val(Text5.Text) End If ' Bild speichern (als Bitmap) SavePicture Picture2.Image, OrdnerZiel & _ "\" & sFilename & "-small.bmp" End If End Select End If End If DirName = Dir Wend Screen.MousePointer = 0 MsgBox "Die Vorschaubilder wurden erstellt.", 64 ' Anwendung beenden Unload Me End End Sub ' Programm beenden Private Sub cmdCancel_Click() Unload Me End End Sub Vorschaubilder im JPEG-Format speichern Schlussbemerkungen Viel Spaß beim Ausprobieren! Dieser Workshop wurde bereits 20.686 mal aufgerufen.
Anzeige
![]() ![]() ![]() (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
TOP Entwickler-Paket ![]() TOP-Preis!! Mit der Developer CD erhalten Sie insgesamt 24 Entwickler- komponenten und Windows-DLLs. Die Einzelkomponenten haben einen Gesamtwert von 1605.50 EUR... Tipp des Monats ![]() Dieter Otter PopUp-Menü wird nicht angezeigt :-( In diesem Tipp verraten wir Ihnen, wie Sie Probleme mit PopUp-Menüs umgehen können, wenn diese unter bestimmten Umständen einfach nicht angezeigt werden. Neu! sevEingabe 3.0 ![]() Einfach stark! Ein einziges Eingabe-Control für alle benötigten Eingabetypen und -formate, inkl. Kalender-, Taschenrechner und Floskelfunktion, mehrspaltige ComboBox mit DB-Anbindung, ImageComboBox u.v.m. |
|||||||||||||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |