Mit nachfolgendem Code werden die Bilddateien eines Ordners als Miniatutansicht in einem MS-FlexGrid angezeigt. Beim Überfahren des Grids mit der Maus werden Dateinamen und Bildmaße angezeigt. Ein Click auf ein Bild zeigt es als Vollbild an. Mit einem Click auf das Vollbild wird dieses wieder geschlosssen. Alle Vorgänge können auch mit Esc beendet werden. Der Aufruf erfolgt mit: Call ShowFolder("Ordnerpfad") Benötigte Controls:
VB6-Code ' Bilddateien eines Ordners als Miniaturansicht in Flexgrid anzeigen ' Copyright © 2015 by Zardoz Option Explicit ' API Private Declare Function StretchBlt Lib "gdi32" ( _ ByVal hdc As Long, _ ByVal X As Long, _ ByVal Y As Long, _ ByVal nWidth As Long, _ ByVal nHeight As Long, _ ByVal hSrcDC As Long, _ ByVal xSrc As Long, _ ByVal ySrc As Long, _ ByVal nSrcWidth As Long, _ ByVal nSrcHeight As Long, _ ByVal dwRop As Long) As Long Private Declare Function SetStretchBltMode Lib "gdi32" ( _ ByVal hdc As Long, _ ByVal nStretchMode As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" ( _ ByVal hdc As Long) As Long Private Declare Function DeleteDC Lib "gdi32" ( _ ByVal hdc As Long) As Long Private Declare Function SelectObject Lib "gdi32" ( _ ByVal hdc As Long, _ ByVal hObject As Long) As Long Private Declare Function SetBrushOrgEx Lib "gdi32" ( _ ByVal hdc As Long, _ ByVal nXOrg As Long, _ ByVal nYOrg As Long, _ lppt As Any) As Long ' Konstanten Private Const HALFTONE = 4 ' UDT Private Type FData FN As String SW As Integer SH As Integer End Type Private flg1 As Boolean Private flgBusy As Boolean Private MABreite As Integer Private MAHoehe As Integer Private FileInfo() As FData Private Sub Form_Load() ' Starteinstellungen With Me .BackColor = RGB(90, 90, 90) .WindowState = vbMaximized .KeyPreview = True .Caption = "Miniaturansicht" End With With MSFlexGrid1 .Left = 0 .Top = 0 .Visible = False End With Picture1.Visible = False File1.Visible = False flg1 = False End Sub Private Sub Form_Activate() Dim Dat1 As String If flg1 = True Then Exit Sub ' nur einmal ausführen flg1 = True DoEvents ' Vollständiger Pfad eines Ordners mit Bildern hier einsetzen: Dat1 = "H:\Benutzer\Dieter Otter\Bilder\Kommunion" ' Grid füllen Call ShowFolder(Dat1) End Sub Private Sub ShowFolder(Folder As String) ' Miniaturansicht in Grid laden Dim Dat2 As String, LC As Long, x1 As Long, y1 As Long Dim i As Long, FN As String, PicW As Integer, PicH As Integer Dim R1 As Long, C1 As Long, W1 As Long, H1 As Long, Ttl As String Me.MousePointer = vbHourglass Me.ScaleMode = vbPixels Ttl = Me.Caption If Dir$(Folder, vbDirectory) = "" Then Me.MousePointer = vbDefault MsgBox "Ungültiger Ordnerpfad:" & vbCr & Folder, vbExclamation + vbOKOnly, App.Title Unload Me Exit Sub End If With File1 .Pattern = "*.jpeg;*.jpg;*.bmp;*.gif;*.wmf;*.emf" .Path = Folder LC = .ListCount End With If LC = 0 Then Me.MousePointer = vbDefault MsgBox "Keine anzeigbaren Bilddateien im angegebenen Ordner." & _ vbCrLf & Folder, vbExclamation + vbOKOnly, App.Title Unload Me Exit Sub End If W1 = 1200 ' Gridbreite in Pixeln H1 = 700 ' Gridhöhe in Pixeln MABreite = 120 ' max. Breite Miniaturansicht in Pixeln, hier einstellen MAHoehe = 80 ' max. Höhe Miniaturansicht in Pixeln, hier einstellen flgBusy = True x1 = 0 y1 = 0 If W1 > Me.ScaleWidth Then W1 = Me.ScaleWidth - MSFlexGrid1.Left * 2 If H1 > Me.ScaleHeight Then H1 = Me.ScaleHeight - MSFlexGrid1.Top C1 = Int((W1 - 8) / (MABreite + 2)) If C1 < 1 Then C1 = 1 R1 = -Int(-LC / C1) If R1 < 1 Then R1 = 1 ReDim FileInfo(C1 - 1, R1 - 1) With MSFlexGrid1 .Clear .Enabled = False .Move .Left, .Top, W1, H1 .BackColorBkg = Me.BackColor .FixedRows = 0 .FixedCols = 0 .Cols = C1 .Rows = R1 .RowHeight(-1) = (MAHoehe + 2) * Screen.TwipsPerPixelX .ColWidth(-1) = (MABreite + 2) * Screen.TwipsPerPixelY .ScrollTrack = True .ScrollBars = flexScrollBarVertical .Visible = True For i = 0 To LC - 1 ' Fortschrittsanzeige Me.Caption = CStr(Int(i / (LC - 1) * 100)) & " %" FN = File1.List(i) Dat2 = Folder & "\\" & FN If ScalePicture(Dat2, True, PicW, PicH) = 1 Then With FileInfo(x1, y1) .FN = FN .SW = PicW .SH = PicH End With .Redraw = False .Col = x1 .Row = y1 .CellPictureAlignment = flexAlignCenterCenter Set .CellPicture = Picture1.Image Picture1.Cls .Redraw = True End If x1 = (x1 + 1) Mod C1 If x1 = 0 Then y1 = y1 + 1 If y1 < .Rows Then If .RowIsVisible(y1) = False Then .TopRow = y1 End If End If DoEvents If flgBusy = False Then Exit For Next i .TopRow = 0 .Row = 0 .Col = 0 .Enabled = True .SetFocus End With Me.Caption = Ttl flgBusy = False Me.MousePointer = vbDefault End Sub Private Sub MSFlexGrid1_Click() ' Vollbildansicht Dim Dat2 As String, FN As String FN = FileInfo(MSFlexGrid1.Col, MSFlexGrid1.Row).FN If Trim$(FN) = "" Then Beep Exit Sub End If Me.MousePointer = vbHourglass Dat2 = File1.Path & "\\" & FN If ScalePicture(Dat2, False) = 1 Then Picture1.ZOrder vbBringToFront Picture1.Visible = True End If Me.MousePointer = vbDefault End Sub Private Sub MSFlexGrid1_KeyDown(KeyCode As Integer, Shift As Integer) ' Bildauswahl über Tastatur If KeyCode = vbKeyReturn Then Call MSFlexGrid1_Click End Sub Private Sub MSFlexGrid1_MouseMove(Button As Integer, Shift As Integer, _ X As Single, Y As Single) ' Dateiname, Breite und Höhe anzeigen Dim Out As String With FileInfo(MSFlexGrid1.MouseCol, MSFlexGrid1.MouseRow) If Trim$(.FN) = "" Then Out = "" Else Out = .FN & Space$(3) & CStr(.SW) & " " & _ Chr$(215) & CStr(.SH) & " Pixel" End If End With MSFlexGrid1.ToolTipText = Out End Sub Private Sub Picture1_Click() ' Vollbildansicht schließen Picture1.Visible = False Picture1.Cls End Sub Private Function ScalePicture(PicPath As String, flgMA As Boolean, _ Optional PicW As Integer, Optional PicH As Integer) As Byte ' Bild laden und scalieren Dim MaxBreite As Long, MaxHoehe As Long Dim ZielBreite As Single, ZielHoehe As Single Dim QuellBreite As Single, QuellHoehe As Single Dim Fkt1 As Single, Fkt2 As Single, x1 As Single, y1 As Single Dim OldMode As Long, FileExt As String Dim P1hdc As Long, P1OldHandle As Long Dim TmpPic As StdPicture If Dir$(PicPath) = "" Then Me.MousePointer = vbDefault MsgBox "Datei nicht gefunden:" & vbCr & PicPath, vbExclamation + vbOKOnly, App.Title Me.MousePointer = vbHourglass ScalePicture = 0 Exit Function End If Set TmpPic = LoadPicture(PicPath) FileExt = LCase$(Mid$(PicPath, InStrRev(PicPath, ".") + 1)) If flgMA = True Then MaxBreite = MABreite MaxHoehe = MAHoehe Else MaxBreite = Me.ScaleWidth MaxHoehe = Me.ScaleHeight End If With Picture1 .Visible = False .BorderStyle = vbBSNone .ScaleMode = vbPixels .AutoRedraw = True QuellBreite = Int(0.5 + .ScaleX(TmpPic.Width, vbHimetric)) QuellHoehe = Int(0.5 + .ScaleY(TmpPic.Height, vbHimetric)) If FileExt = "gif" Then ' Sonderfall Gif-Datei .Move 0, 0, QuellBreite, QuellHoehe .BackColor = vbWhite ' Hintergrundfarbe Gif-Bild .Cls Set .Picture = TmpPic Set TmpPic = .Image Set .Picture = LoadPicture() End If Fkt1 = MaxBreite / QuellBreite Fkt2 = MaxHoehe / QuellHoehe If Fkt2 < Fkt1 Then Fkt1 = Fkt2 ZielBreite = QuellBreite * Fkt1 ZielHoehe = QuellHoehe * Fkt1 If ZielBreite < 1 Then ZielBreite = 1 If ZielHoehe < 1 Then ZielHoehe = 1 If flgMA = True Then .Move 0, 0, ZielBreite, ZielHoehe Else x1 = (MaxBreite - ZielBreite) / 2 y1 = (MaxHoehe - ZielHoehe) / 2 .Move x1, y1, ZielBreite, ZielHoehe End If .Cls Select Case FileExt Case "wmf", "emf" ' Sonderfall Metafile .BackColor = vbWhite ' Hintergrundfarbe Metafile-Bild .PaintPicture TmpPic, 0, 0, ZielBreite, ZielHoehe Case Else ' sonstige Dateitypen P1hdc = CreateCompatibleDC(0) P1OldHandle = SelectObject(P1hdc, TmpPic.Handle) OldMode = SetStretchBltMode(.hdc, HALFTONE) Call StretchBlt(.hdc, 0, 0, ZielBreite, ZielHoehe, _ P1hdc, 0, 0, QuellBreite, QuellHoehe, vbSrcCopy) Call SetStretchBltMode(.hdc, OldMode) Call SetBrushOrgEx(.hdc, 0, 0, ByVal 0) Call SelectObject(P1hdc, P1OldHandle) Call DeleteDC(P1hdc) End Select End With Set TmpPic = LoadPicture() PicW = QuellBreite PicH = QuellHoehe ScalePicture = 1 End Function Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) ' Abbruch mit Esc-Taste If KeyCode = vbKeyEscape Then If Picture1.Visible = True Then Call Picture1_Click ElseIf flgBusy = True Then flgBusy = False Else Unload Me End If End If End Sub Private Sub Form_Unload(Cancel As Integer) ' Speicher freigeben Erase FileInfo MSFlexGrid1.Clear End Sub Dieser Tipp wurde bereits 8.216 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (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. |
Neu! sevDTA 3.0 Pro SEPA mit Kontonummernprüfung Erstellen von SEPA-Dateien mit integriertem BIC-Verzeichnis und Konto- nummern-Prüfverfahren, so dass ungültige Bankdaten bereits im Vorfeld ermittelt werden können. Tipp des Monats Mai 2024 Hermann Röttger Wochentage eines Datumsbereichs ermitteln Wochentage eines Datumsbereichs ermitteln, optional mit Feiertagsberechnung 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... |
||||||||||||||||
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. |