Dateien aus Verzeichnissen lesen, Dateinamen in Hyperlinks umwandeln, Symbolleiste erzeugen

Treeview-Control, BrowseInfo, ShowDirectory, msoFileTypeExcelWorkbooks, msoFileTypeAllFiles
Sub DateienAuflisten()	Makro zum Auflisten von Dateien eines Verzeichnisses.
Dim i As Long
Const verz = "F:\"	Dateien werden aus diesem Verzeichnis gelesen.
On Error GoTo fehler
ChDir verz	Wechseln in das gewünschte Verzeichnis, um das Lesen
Range("A1").Select	zu starten.
With Application.FileSearch	FileSearch ermittelt Dateien.
.NewSearch
.LookIn = verz	LookIn beginnt die Suche im Hauptverzeichnis.
.SearchSubFolders = False	TRUE, falls auch Unterverzeichnisse durchsucht werden sollen.
.FileType = msoFileTypeExcelWorkbooks	Nur Excel-Dateien suchen (alle Dateien = msoFileTypeAllFiles)
.Execute	Ausführen.
For i = 1 To .FoundFiles.Count
ActiveCell.Value = .FoundFiles(i)	Gefundene Dateinamen werden ins Worksheet geschrieben.
ActiveCell.Offset(1, 0).Select
Next i
End With
Exit Sub
fehler:
MsgBox "Es gibt kein Verzeichnis mit dem Namen " & verz
End Sub
Sub DateienInHyperlinksWandeln()	Zweiter Schritt: Umwandeln in Hyperlinks.
Dim Bereich As Range
Dim Zelle As Range
Range("A1").Select
Set Bereich = ActiveCell.CurrentRegion
For Each Zelle In Bereich
Zelle.Hyperlinks.Add Zelle, Zelle.Value	Die Sprung-Adresse geht direkt aus dem Zelleneintrag hervor.
Next Zelle
End Sub
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260
Private Declare Function SHBrowseForFolder Lib "shell32" _
(lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" _
(ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _
(ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot  As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags   As Long
lpfnCallback   As Long
lParam As Long
iImage As Long
End Type
Dim dat_ende$, filenam$, string1$
Dim i%, k%, n%, length%, X&, Y&, Zelle As Range
Sub DateienAuflisten()
On Error Resume Next
frmDrucken.Show
End Sub
Public Function mach_index(verz1())
On Error Resume Next
If ActiveSheet.Name = "Music" Then
Application.DisplayAlerts = False
Application.CommandBars("Update").Delete
On Error GoTo fehler
For k = 1 To UBound(verz1)	Laufwerke prüfen.
ChDir verz1(k)
Next
Call freeze_panes
For n = 1 To UBound(verz1)	Laufwerke verarbeiten.
Call verz(verz1(n))
Next
Call copy_column
Call hyperlink_add
Call pfad_entfernen
Call sort_tabelle
Call mp3_entfernen
Call string_teilen
Call move_spalte1
Call selection_font
Call spalten_titel
Call last_step
Else
GoTo fehler
End If
Exit Function
fehler:
If ActiveSheet.Name = "Test" Then ActiveSheet.Name = "Music"
Range("A1").Select
MsgBox "Exit - Error"
Exit Function
End Function
Private Sub freeze_panes()
ActiveSheet.Name = "Test"
ActiveWindow.FreezePanes = False
Cells.Select
With Selection
.ClearContents
.Delete Shift:=xlUp
End With
Cells.Select
With Selection
.NumberFormat = "@"
.Interior.ColorIndex = xlNone
End With
Range("D9").Select
ActiveCell.FormulaR1C1 = "B i t t e   w a r t e n . . ."
Range("A1").Select
Application.ScreenUpdating = False
End Sub
Private Sub verz(vvv)
With Application.FileSearch
.NewSearch
.LookIn = vvv
.SearchSubFolders = True
.FileType = msoFileTypeAllFiles	Alle Dateien wählen.
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
filenam = .FoundFiles.Item(i)
dat_ende = Right(filenam, 3)	Dateiendung ermitteln.
If dat_ende = "mp3" Or dat_ende = "wav" Or _
dat_ende = "wma" Or dat_ende = "MP3" Or _
dat_ende = "WAV" Or dat_ende = "WMA" Then
Call set_cell_value(filenam)
End If
filenam = vbNullString
dat_ende = vbNullString
Next i
ElseIf .Execute = 0 Then
MsgBox "Sorry -> keine Dateien vorhanden"
End If
End With
End Sub
Private Function set_cell_value(filen As String)
Call ReadMP3(filen, True, True)	Function zum Lesen des MP3-Tags siehe Seite 546 !
ActiveCell.Value = filen
If GetMP3Info.Duration = vbNullString Or _
GetMP3Info.Duration = "00:00:00" Then	Wenn Zeit nicht ermittelbar.
ActiveCell.Offset(0, 6).Select
Selection.NumberFormat = "#,##0 ""KB"""
ActiveCell.Value = GetMP3Info.FileLaenge
ActiveCell.Offset(1, -6).Select
Else
ActiveCell.Offset(0, 4).Select
Selection.NumberFormat = "[hh]:mm:ss"
ActiveCell.FormulaR1C1 = Format(GetMP3Info.Duration, "hh:mm:ss")
ActiveCell.Offset(0, 1).Select
Selection.NumberFormat = "#,##0 ""kb/s"""
ActiveCell.Value = GetMP3Info.Bitrate
ActiveCell.Offset(0, 1).Select
Selection.NumberFormat = "#,##0 ""KB"""
ActiveCell.Value = GetMP3Info.FileLaenge
ActiveCell.Offset(1, -6).Select
End If
End Function
Private Sub copy_column()
Columns("A:A").Select
Selection.Copy
Range("B1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
Private Sub hyperlink_add()
For Each Zelle In Range("A:A")
If Zelle > vbNullString Then
Zelle.Hyperlinks.Add Zelle, Zelle.Value
End If
Next
End Sub
Private Sub pfad_entfernen()
For Each Zelle In Range("A:A")
Dim str_left$
If Zelle > vbNullString Then
length = Len(Zelle)
str_left = vbNullString
For X = length To 1 Step -1
If Mid(Zelle, X, 1) = Application.PathSeparator Then
Exit For
End If
Next X
For Y = X To 0 Step -1
If Y = 0 Then
Zelle = str_left
Exit For
End If
str_left = Mid(Zelle, Y, 1) & str_left
Next Y
End If
Next Zelle
For Each Zelle In Range("B:B")
If Zelle > vbNullString Then
length = Len(Zelle)
string1 = vbNullString
For X = length To 1 Step -1
If Mid(Zelle, X, 1) = Application.PathSeparator Then
Zelle = string1
Exit For
End If
string1 = Mid(Zelle, X, 1) & string1
Next X
End If
Next Zelle
End Sub
Sub sort_tabelle()
Columns("A:E").Select
Selection.Sort Key1:=Range("C1"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False,  _
Orientation:=xlTopToBottom
End Sub
Private Sub mp3_entfernen()
Cells.Replace What:="  ", Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Cells.Replace What:=" - ", Replacement:="-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Cells.Replace What:=.mp3", Replacement:=vbNullString, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Cells.Replace What:=".wav", Replacement:=vbNullString, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Cells.Replace What:=".wma", Replacement:=vbNullString, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
End Sub
Sub string_teilen()
Columns("C:C").Select
Selection.TextToColumns Destination:=Range("C1"), _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, Other:=True, OtherChar:="-", _
FieldInfo:=Array(Array(1, 2), Array(2, 1))
End Sub
Private Sub move_spalte1()
Columns("A:A").Select
Selection.Cut Destination:=Columns("H:H")
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Application.CutCopyMode = False
End Sub
Private Sub selection_font()
Range("A:F").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
.InsertIndent 1
.Font.Name = "Arial"
.Font.Size = 9
.Font.Bold = False
.Font.Underline = xlUnderlineStyleNone
End With
Columns("C:C").Select
Selection.HorizontalAlignment = xlCenter
Columns("D:E").Select
Selection.HorizontalAlignment = xlRight
End Sub
Private Sub spalten_titel()
Columns("A:E").Select
Selection.Interior.ColorIndex = xlNone
Selection.Font.ColorIndex = 0
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
Selection.NumberFormat = """T o t a l :    ""###0""   T i t e l"""
ActiveCell.FormulaR1C1 = "=COUNTA(R[1]C:R[9999]C)"
Range("C1").Select
Selection.NumberFormat = "[hh]:mm"    ''':ss"
ActiveCell.FormulaR1C1 = "=SUM(R[1]C:R[9999]C)"
Range("B1").Select
Selection.NumberFormat = "[hh]:mm:ss"
ActiveCell.FormulaR1C1 = "=(RC[1])"
Selection.NumberFormat = """Durchschnittszeit:    ""mm:ss"
ActiveCell.FormulaR1C1 = "=SUM(RC[1]/RC[-1])"
Range("D1").Select
ActiveCell.FormulaR1C1 = "  B i t r a t e "
Range("E1").Select
Selection.NumberFormat = "#,##0 "" MB"""
ActiveCell.FormulaR1C1 = "=SUM(R[1]C:R[9999]C)/1024"
Columns("A:A").Select
Selection.ColumnWidth = 30
Columns("B:B").Select
Selection.ColumnWidth = 40
Columns("C:E").Select
Selection.Columns.AutoFit
Columns("F:F").Select
Selection.ColumnWidth = 25
Range("F1").Select
ActiveCell.FormulaR1C1 = "P f a d   &   H y p e r l i n k"
Rows("1:1").Select
Selection.Font.Bold = True
End Sub
Private Sub last_step()
Application.ScreenUpdating = True
ActiveCell.SpecialCells(xlLastCell).Select
Range("A2").Select
ActiveWindow.FreezePanes = True
ActiveSheet.Name = "Music"
End Sub
Sub CloseButton()
On Error Resume Next
Application.CommandBars("Update").Delete
End Sub
Function ShowDirectory(sBuf As String)	Öffnet ein Treeview-Control.
Dim lpIDList As Long
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo
szTitle = "Laufwerk / Verzeichnis wählen..."
With tBrowseInfo
.ulFlags = BIF_DONTGOBELOWDOMAIN + _
BIF_RETURNONLYFSDIRS
.lpszTitle = lstrcat(szTitle, "")
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuf = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuf
sBuf = Left(sBuf, InStr(sBuf, vbNullChar) - 1)
End If
End Function
Sowie noch die Makros zur Erzeugung der Symbolleiste:
Private Sub Workbook_BeforeSave(ByVal _
SaveAsUi As Boolean, Cancel As Boolean)
On Error Resume Next
If ActiveSheet.Name = "Music" Then
Application.CommandBars("Update").Delete
End If
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal _
Sh As Object, ByVal Target As Excel.Range)
Dim r$, colr%, c%
Static AlteZelle As Range
On Error GoTo fehler
colr = 0
If ActiveSheet.Name = "Music" Then
r = Left(Target.Address, 3)
If r = "$C$" And Not ActiveCell.Value = "" Then
Call old_cell(AlteZelle)
colr = 36
Target.EntireColumn.Interior.ColorIndex = colr
Set AlteZelle = Target
Application.StatusBar = "Zellposition: " & Target.Address & "; " _
& "Colour: " & colr
ElseIf (r <= "$F$") And Not ActiveCell.Value = "" Then
Call old_cell(AlteZelle)
colr = 20
Target.EntireRow.Interior.ColorIndex = colr
Set AlteZelle = Target
Application.StatusBar = "Zellposition: " & Target.Address & "; " _
& "Colour: " & colr
Else
Call old_cell(AlteZelle)
Application.StatusBar = vbNullString
End If
End If
Exit Sub
fehler:
Exit Sub
End Sub
Private Sub Workbook_Open()
Dim objBar As CommandBar
Dim objButton_1 As CommandBarButton
Dim objButton_2 As CommandBarButton
On Error Resume Next
Application.ScreenUpdating = False
Application.CommandBars("Update").Delete
On Error GoTo fehler
Set objBar = Application.CommandBars.Add("Update", _
msoBarFloating) 'msoBarTop)
Set objButton_1 = objBar.Controls.Add
With objButton_1
.Caption = " Music Update "
.Style = msoButtonCaption
.OnAction = "DateienAuflisten"
End With
Set objButton_2 = objBar.Controls.Add
With objButton_2
.Caption = " Close "
.Style = msoButtonCaption
.OnAction = "CloseButton"
.BeginGroup = True
End With
With objBar
.Position = msoBarFloating
.Left = 480
.Top = 140
.Visible = True
End With
Application.StatusBar = vbNullString
Application.ScreenUpdating = True
fehler:
Exit Sub
End Sub
Sub old_cell(AZ)
On Error Resume Next
If Not AZ Is Nothing Then
AZ.EntireRow.Interior.ColorIndex = xlColorIndexNone
AZ.EntireColumn.Interior.ColorIndex = xlColorIndexNone
End If
End Sub
Sowie noch die Makros der ListBox:
Sub UserForm_Initialize()
Dim sBuffer As String
Dim Wb As Workbook
Dim eintrag%
eintrag = 0
Call ShowDirectory(sBuffer)	Öffnet ein Treeview-Control.
If sBuffer <> vbNullString Then
lstDrucken.AddItem sBuffer
eintrag = eintrag + 1
sBuffer = vbNullString
End If
quest = MsgBox("Noch weitere Laufwerke?", vbYesNo, "Frage")
schleife:
If quest = vbNo Then
If eintrag < 1 Then
Unload Me
End If
Exit Sub
Else
Call ShowDirectory(sBuffer)
If sBuffer <> vbNullString Then
lstDrucken.AddItem sBuffer
eintrag = eintrag + 1
sBuffer = vbNullString
End If
quest = MsgBox("Noch weitere Laufwerke/Verzeichnisse?", _
vbYesNo, "Frage")
GoTo schleife
End If
End Sub
Sub cmdIndex_Click()
Dim arrWb(), i%, i2%
For i = 0 To lstDrucken.ListCount - 1
i2 = i2 + 1
ReDim Preserve arrWb(1 To i2)
arrWb(i2) = lstDrucken.List(i)
Next i
Unload Me
Call mach_index(arrWb())
End Sub
Private Sub lstDrucken_DblClick(ByVal Cancel As _
MSForms.ReturnBoolean)
With lstDrucken
If (.ListIndex >= 0) Then
.ControlTipText = .List(.ListIndex)
Else
.ControlTipText = ""
End If
End With
End Sub
Sub cmdStop_Click()
Unload Me
End Sub