ListViewBox als Thumbnail


In diesem Beispiel werden wir eine ListViewBox für die Anzeige von Bild-Dateien in einem Verzeichnis als Thumbnail nutzen. Wir laden die Bilder in eine PictureBox und werden mit Hilfe der StretchBlt Methode alle geladenen Bilder auf eine Größe bringen und diese in eine ImageListBox ablegen, von der man problemlos das ListView-Feld mit den Bildern laden kann. Weiterhin wird beim Rechtsklick das Click-Event und das PopMenü verwirklicht. Das Ergebnis ist ein Thumbnail-Viewer mit Explorer-Eigenschaften.
Laden Sie sich die Zip-Datei mit VB 6 Source Code hinunter und probieren Sie es mal aus.

Projekt - Download
 

 
© FienauBerlin   Web-ComputerEcke.de
 

Quell-Code
Option Explicit
 
Private Declare Function ShellExecute Lib "shell32.dll" _
        Alias "ShellExecuteA" (ByVal hWnd As Long, _
        ByVal lpOperation As String, ByVal lpFile As String, _
        ByVal lpParameters As String, _
        ByVal lpDirectory As String, ByVal nShowCmd As Long _
        ) As Long
 
 
Dim selected_index  'Index der zuletzt angeklickten Bitmap
Dim stop_read, PopMenu As Boolean
Dim stretch As Boolean, Summe%
Dim fso As New FileSystemObject   'Zugang zu FSO-Objekten

Private Sub Form_Load() ' stretch = True End Sub
Private Sub mnuStop_Click() stop_read = True End Sub
'Spaltenkopf: A - Z oder Z - A Private Sub ListV_ColumnClick(ByVal ColumnHeader As ColumnHeader) If ListV.SortKey = ColumnHeader.Index - 1 Then ListV.SortOrder = 1 - ListV.SortOrder Else ListV.SortKey = ColumnHeader.Index - 1 ListV.SortOrder = lvwAscending End If ListV.Sorted = True End Sub
Private Sub ListV_ItemClick(ByVal Item As ListItem) selected_index = Item.Index End Sub
Private Sub mnuRaster_Click() 'Linien in ListView1 ein- od. ausschalten If mnuRaster.Checked Then ListV.GridLines = False mnuRaster.Checked = False Else ListV.GridLines = True mnuRaster.Checked = True ListV.Font.Size = 9: ListV.View = lvwReport mnuReport_Click End If End Sub
Private Sub mnuList_Click() ListV.Font.Size = 9: ListV.View = lvwList mnuSmallSymbols.Checked = False: mnuSymbols.Checked = False mnuList.Checked = True: mnuReport.Checked = False ListV.GridLines = False End Sub
Private Sub mnuSmallSymbols_Click() ListV.View = lvwSmallIcon ListV.GridLines = False mnuSmallSymbols.Checked = True: mnuSymbols.Checked = False mnuList.Checked = False: mnuReport.Checked = False End Sub
Private Sub mnuSymbols_Click() ListV.View = lvwIcon mnuSmallSymbols.Checked = False: mnuSymbols.Checked = True mnuList.Checked = False: mnuReport.Checked = False ListV.GridLines = False End Sub
Private Sub mnuReport_Click() ListV.Font.Size = 9: ListV.View = lvwReport mnuSmallSymbols.Checked = False: mnuSymbols.Checked = False mnuList.Checked = False: mnuReport.Checked = True End Sub
Private Sub mnu32_Click() Picture2.Width = 615: Picture2.Height = 570 ListV.Font.Size = 7: ReadListView End Sub
Private Sub mnu48_Click() Picture2.Width = 858: Picture2.Height = 795 ListV.Font.Size = 7: ReadListView End Sub
Private Sub mnu64_Click() Picture2.Width = 1100: Picture2.Height = 1020 ListV.Font.Size = 8: ReadListView End Sub
Private Sub mnu96_Click() Picture2.Width = 1635: Picture2.Height = 1515 ListV.Font.Size = 10: ReadListView End Sub
Private Sub mnu128_Click() Picture2.Width = 2169: Picture2.Height = 2010 ListV.Font.Size = 12: ReadListView End Sub
Private Sub mnuStretch_Click() If stretch = True Then stretch = False mnuStretch.Checked = False Else stretch = True mnuStretch.Checked = True End If ReadListView End Sub
Private Sub Drive1_Change() Dir1.Path = Drive1.Drive End Sub
Private Sub Dir1_MouseDown(Button As Integer, Shift As Integer, _ X As Single, Y As Single) 'Verzeichniswechsel per einfachen Mausklick Dir1.Path = Dir1.List(Dir1.ListIndex) ReadListView End Sub
Sub ReadListView() 'Pfadwechsel ReadListV Dir1.Path End Sub
' Bitmaps suchen und einfügen Sub ReadListV(pth$) On Error Resume Next Dim litem As ListItem, but As Button Dim fld As Folder, fil As File Dim typ$, filnam$ Dim i&, iconb&, iconh&, b&, h&, x0&, y0&, siconb&, siconh& Dim lastupdate& Dim bz, hz StBar.Panels(2).Text = "Kein Objekt markiert" Summe = 0 lastupdate = Timer MousePointer = 13 stop_read = False mnuStop.Enabled = True ' Initialisierungsarbeiten iconb = Picture2.ScaleWidth: iconh = Picture2.ScaleHeight siconb = Picture3.ScaleWidth: siconh = Picture3.ScaleHeight ListV.ListItems.Clear 'ListView löschen ListV.Icons = ListImagesDummy ListV.SmallIcons = ListImagesDummy ListImagesBig.ListImages.Clear 'Icon-Feld löschen ListImagesBig.ImageWidth = iconb ListImagesBig.ImageHeight = iconh ListImagesBig.MaskColor = ListV.BackColor ListImagesSmall.ListImages.Clear 'Icon-Feld löschen ListImagesSmall.ImageWidth = siconb ListImagesSmall.ImageHeight = siconh ListImagesSmall.MaskColor = ListV.BackColor If Right(pth, 1) <> "\" Then pth = pth + "\" Set fld = fso.GetFolder(pth) For Each fil In fld.Files filnam = fil.Name If Len(filnam) > 4 Then typ = LCase(Right(filnam, 3)) 'Suchmaske If typ = "bmp" Or typ = "ico" Or typ = "gif" Or typ = "jpg" _ Or typ = "cur" Or typ = "wmf" Then i = i + 1 'Bitmap laden Picture1.Picture = LoadPicture(pth + filnam) If Err <> 0 Then Picture1.Picture = BildFehler.Picture: Err = 0 End If 'Bitmap für großes Icon stretchen b = Picture1.ScaleWidth: h = Picture1.ScaleHeight Picture2.BackColor = &HE0E0E0 'Hintergrundsfarbe Picture2.AutoRedraw = True If Not stretch Then If Picture1.Width < Picture2.Width And _ Picture1.Height < Picture2.Height Then Picture2.PaintPicture Picture1.Picture, _ (Picture2.ScaleWidth / 2) - (Picture1.ScaleWidth / 2), _ (Picture2.ScaleHeight / 2) - (Picture1.ScaleHeight / 2 _ ) ', iconb, iconh, 0, 0, b * 2, h * 2 ElseIf h > b Then 'Höhe bz = b / (h / iconh) x0 = (iconb - bz) / 2 ' zentrieren Picture2.PaintPicture Picture1.Picture, x0, 0, _ iconb, iconh, 0, 0, h, h ElseIf b = h Then Picture2.PaintPicture Picture1.Picture, 0, 0, _ iconb, iconh, 0, 0, b, h ElseIf b > h Then 'Breite hz = h / (b / iconb) y0 = (iconh - hz) / 2 Picture2.PaintPicture Picture1.Picture, 0, y0, _ iconb, iconh, 0, 0, b, b End If Else Picture2.PaintPicture Picture1.Picture, 0, 0, _ iconb, iconh, 0, 0, b, h End If Picture2.Refresh: Picture2.AutoRedraw = False ListImagesBig.ListImages.Add i, , Picture2.Image Picture2.Picture = LoadPicture(): Picture2.Cls 'dasselbe für kleines Icons Picture3.BackColor = RGB(255, 255, 255) Picture3.AutoRedraw = True Picture3.PaintPicture Picture1.Picture, 0, 0, _ siconb, siconh, 0, 0, b, h Picture3.Refresh: Picture3.AutoRedraw = False ListImagesSmall.ListImages.Add i, , Picture3.Image If i = 1 Then ListV.Icons = ListImagesBig ListV.SmallIcons = ListImagesSmall End If 'ListView-Einträge: Name, Datum, Größe Set litem = ListV.ListItems.Add(, , filnam, i, i) litem.SubItems(1) = Space(10 - Len(Str(fil.Size))) & _ fil.Size litem.SubItems(2) = Format(fil.DateLastModified, _ "yy-mm-dd hh:nn") litem.SubItems(3) = Space(6 - Len(Str(b))) & b litem.SubItems(4) = Space(6 - Len(Str(h))) & h Summe = litem.Index If Summe < 2 Then StBar.Panels(1).Text = Summe & " Bilddatei" Else StBar.Panels(1).Text = Summe & " Bilddateien" End If StBar.Panels(2).Text = " Bilder werden geladen" If (i Mod 5) = 0 And Timer - lastupdate > 2 Then DoEvents: If stop_read Then Exit For lastupdate = Timer End If End If End If Next If Summe = 0 Then StBar.Panels(1).Text = " 0 Objekt(e)" StBar.Panels(2).Text = "Kein Objekt markiert" mnuStop.Enabled = False MousePointer = 0 End Sub
Private Sub ListV_DblClick() MsgBox (ListV.ListItems(selected_index) + vbCrLf + _ "Hier könnte eine Form geöffnet werden!"), _ vbInformation, "Thumbnails" End Sub
Private Sub ListV_MouseDown(Button As Integer, Shift As Integer, _ X As Single, Y As Single) 'Popup-Menü Datei If Button = vbRightButton Then PopMenu = True End If End Sub
Private Sub ListV_Click() On Error Resume Next Dim Path$, Datei$ Path$ = Dir1.Path If Right(Path, 1) <> "\" Then Path = Path + "\" If selected_index <> "" Then _ Datei$ = Path$ + ListV.ListItems(selected_index) StBar.Panels(2).Text = " Adresse: " & Datei$ 'Mit diesem Trick läßt sich der Rechtsklick als Click-Event 'mit PopMenu verwirklichen ;-) If PopMenu = True Then Me.PopupMenu mnuView MsgBox (ListV.ListItems(selected_index) + vbCrLf + _ "Click-Event und PopMenu ;-)"), vbInformation, "Thumbnails" End If PopMenu = False End Sub
' neue Fenstergröße Private Sub Form_Resize() Dim f As Form If WindowState = vbMinimized Then Exit Sub ' das sind Twips (ScaleMode=1 für Formular) If Width < 3000 Then Width = 3000: Exit Sub If Height < 2250 Then Height = 2250: Exit Sub SplitLine.Top = 400 Dir1.Top = 400 ListV.Top = 400 If SplitLine.Left > ScaleWidth - 1500 Then ChangeSplitting ScaleWidth - 1500 End If Dir1.Height = ScaleHeight - Dir1.Top - StBar.Height ListV.Height = ScaleHeight - ListV.Top - StBar.Height ListV.Width = ScaleWidth - ListV.Left - 45 Drive1.Width = ScaleWidth - 180 SplitLine.Height = ScaleHeight - SplitLine.Top - StBar.Height End Sub
' Schiebebalken zwischen Dir1 und ListView verändern Private Sub Dir1_DragDrop(Source As Control, X As Single, Y As Single) ChangeSplitting Dir1.Left + X End Sub
Private Sub ListV_DragDrop(Source As Control, X As Single, Y As Single) ChangeSplitting ListV.Left + X End Sub
Sub ChangeSplitting(X) If X < 50 Then X = 50 If X > ScaleWidth - 50 Then X = ScaleWidth - 50 Dir1.Width = X - 30 SplitLine.Left = X ListV.Left = SplitLine.Left + SplitLine.Width ListV.Width = ScaleWidth - ListV.Left End Sub