vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
TOP-Angebot: 17 bzw. 24 Entwickler-Vollversionen zum unschlagbaren Preis!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2024
 
zurück
Rubrik: Grafik und Font · Sonstiges   |   VB-Versionen: VB610.08.15
Bilddateien eines Ordners als Miniaturansicht in einem Flexgrid anzeigen

Der Code zeigt die Dateien eines Ordners als Miniaturansicht in einem Grid an.

Autor:   ZardozBewertung:     [ Jetzt bewerten ]Views:  8.155 
ohne HomepageSystem:  WinXP, Win7, Win8, Win10, Win11 Beispielprojekt auf CD 

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:

  • 1 x Picturebox (Picture1)
  • 1 x FileListBox (FileList1)
  • 1 x MSFlexgrid (MSFlexGrid1)

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.155 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!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.
 
   

Druckansicht Druckansicht Copyright ©2000-2024 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
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.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel