str... wie weiter für ID3v1 oder ID3v2
Frank
geht es wie ich mir das denke, den Code so zu modifizieren das auch MP3-Daten ( ID3v.. ) mit ausgegeben werden können, ausser wie im Code zu ersehen ist, nur Ordner und Dateiname z.b.:
Spalte A: C:\musik\Al Bano & Romina Power\ Spalte B: Al Bano - Angell ( & Romina Power ).mp3
Den hier abgebildeten Code habe ich nicht erstellt, benutze ihn nur.
Code:
Option Explicit
Private strList() As String
Private strDir() As String ' hier müsste doch schon die erste Änderung/Ergänzung
Private lngCount As Long ' Private strFilename() As String vorgenommen werden können?)
Public Sub Test_3()
Dim strTMP As String
lngCount = 0
strTMP = GetFolder()
If strTMP = "" Or Left(strTMP, 1) = ":" Then Exit Sub
SearchFiles strTMP, "*.*" 'adapt
If lngCount = 0 Then
MsgBox "No file found"
Exit Sub
End If
With ThisWorkbook.Worksheets(1)
.Cells.Clear
.Range(.Cells(1, 2), Cells(lngCount, 2)) = _
WorksheetFunction.Transpose(strList)
.Range(.Cells(1, 1), Cells(lngCount, 1)) = _
WorksheetFunction.Transpose(strDir)
End With
Call Make_Link
End Sub
Private Function GetFolder() As String
Dim varFolder As Variant
Dim objShell As Object
Dim strPath As String
Set objShell = CreateObject("Shell.Application")
Set varFolder = objShell.BrowseForFolder(0, "Folder", &H10, 17)
If varFolder Is Nothing Then
Set varFolder = Nothing
Set objShell = Nothing
Exit Function
End If
GetFolder = varFolder.Self.Path
Set varFolder = Nothing
Set objShell = Nothing
End Function
Private Sub SearchFiles(strFolder As String, strFileName As String)
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
ReDim Preserve strList(lngCount)
ReDim Preserve strDir(lngCount)
strList(lngCount) = objFile.Name
strDir(lngCount) = strFolder & "\"
lngCount = lngCount + 1
End If
Next
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, strFileName
Next
End Sub
Public Sub Make_Link()
Dim lngRow As Long
With ThisWorkbook.Worksheets(1)
lngRow = .Range("a" & .Rows.Count).End(xlUp).Row
For lngRow = 1 To lngRow
.Hyperlinks.Add Anchor:=.Cells(lngRow, 1), Address:=.Cells(lngRow, 1)
Next lngRow
End With
With ThisWorkbook.Worksheets(1)
lngRow = .Range("B" & .Rows.Count).End(xlUp).Row
For lngRow = 1 To lngRow
.Hyperlinks.Add Anchor:=.Cells(lngRow, 2), Address:=.Cells(lngRow, 1) & .Cells( _
lngRow, 2)
Next lngRow
End With
End Sub
wenn Sie/Er mir helfen kann/will, würde mich ein kurzer Text weiterbringen ( ' das ist der Txt ...... )
Für eure Hilfe will ich mich an der Stelle vorab bedanken
Gruß Frank, der Tüftler ( learning by doing )