C
Carlo
My goal was to import the iTunes Music Library.xml (generated by iTunes)
into a Access 97 Table.
I couldn't find any useful documentation on how to accomplish this through
Access 97 XML classes,
so I created a simple script that gets the job done without using XML. Just
wondering is there an easier way...
----------------------------------------------------------------------------------------------
Note on the code:
Create a form with a button, and assign the Command1_Click() event to it.
Specify the XML name and path.
Not all MP3 tags might be reconized, since this code is based on my personal
7000+ mp3 library.
----------------------------------------------------------------------------------------------
Option Compare Database
Option Explicit
Dim FieldName(30) As String
Dim DataType(30) As String
Dim DataValue(30) As Variant
Private Sub Command1_Click()
On Error GoTo Err_Command1_Click
'DoCmd.Hourglass True
DropTable ("tblImportErrors")
DropTable ("tblTracks")
CreateTable ("tblTracks")
LoadFile ("iTunes Music Library.xml")
'DoCmd.Hourglass False
Exit Sub
Exit_Command1_Click:
Exit Sub
Err_Command1_Click:
Resume Next
End Sub
Private Sub LoadFile(myFile As String)
Dim myLine As String
Dim FieldCount As Integer
Dim Level As Integer
On Error GoTo Err_ProccessFile
Close #1
Open myFile For Input As #1 ' Open file for input.
FieldCount = -1
Level = 0
'Loop until end of file.
Do While Not EOF(1)
Input #1, myLine
'Change Levels up
If Pos(myLine, "<dict>") <> 0 Then
Level = Level + 1
End If
'Change Levels down
If Pos(myLine, "</dict>") <> 0 Then
Level = Level - 1
' If level drops back to 1 exit
If Level = 1 Then
Exit Sub
End If
'If level drops back to 2 insert record
If Level = 2 Then
InsertData ("tblTracks")
'Cleanup Arrays
For FieldCount = 0 To 30
FieldName(FieldCount) = ""
DataType(FieldCount) = ""
DataValue(FieldCount) = ""
Next
FieldCount = -1
End If
End If
'If level is 3 Gather data
If Level = 3 Then
If Pos(myLine, "</key>") <> 0 Then
FieldCount = FieldCount + 1
'DataType
DataType(FieldCount) = GetDataType(myLine)
'FieldName
FieldName(FieldCount) = GetField(myLine)
'DataValue
If DataType(FieldCount) = "date" Then
DataValue(FieldCount) = """" &
GetDateRecord(GetRecord(myLine)) & """"
ElseIf DataType(FieldCount) = "string" Then
DataValue(FieldCount) = """" & GetRecord(myLine) & """"
ElseIf DataType(FieldCount) = "integer" Then
DataValue(FieldCount) = GetRecord(myLine)
End If
End If
End If
Loop
Close #1
Exit Sub
Err_ProccessFile:
Call InsertError(Err.Description, FieldCount)
Resume Next
End Sub
Private Function Pos(myLine As String, Tag As String) As Integer
Pos = InStr(1, myLine, Tag, vbTextCompare)
End Function
Private Function GetField(myLine As String) As String
GetField = Mid(myLine, InStr(1, myLine, "<key>", vbTextCompare) + 5,
InStr(1, myLine, "</key>", vbTextCompare) - 6)
End Function
Private Function GetDataType(myLine As String) As String
Dim C1 As String
C1 = Mid(myLine, InStr(1, myLine, "</key>", vbTextCompare) + 6,
Len(myLine))
GetDataType = Mid(C1, InStr(1, C1, "<", vbTextCompare) + 1, InStr(1, C1,
">", vbTextCompare) - 2)
End Function
Private Function GetRecord(myLine As String) As String
Dim C1 As String
Dim C2 As String
Dim I As Integer
'Convert Double quotes to Single quotes
While InStr(1, myLine, """") > 0
Mid(myLine, InStr(1, myLine, """"), 1) = "'"
Wend
C1 = Mid(myLine, InStr(1, myLine, "</key>", vbTextCompare) + 6,
Len(myLine))
C2 = Mid(C1, InStr(1, C1, ">", vbTextCompare) + 1, Len(myLine))
I = InStr(1, C2, "</")
If I > 0 Then
GetRecord = Left(C2, I - 1)
Else
GetRecord = "" 'does not find the close tag when there is for
example a comma in myLine
End If
End Function
Private Function GetDateRecord(myString As String) As String
'Input 2005-08-11T21:05:05Z'
'Output #2005-08-11 21:05:05#'
Mid(myString, InStr(1, myString, "T"), 1) = " "
Mid(myString, InStr(1, myString, "Z"), 1) = "#"
GetDateRecord = "#" + myString
End Function
Private Function BuildQuery(strTable As String)
Dim FieldCount As Integer
Dim FieldStr As String
Dim DataStr As String
For FieldCount = 0 To 30
If (FieldName(FieldCount) <> "") And (DataValue(FieldCount) <> "")
Then
FieldStr = FieldStr & "[" & FieldName(FieldCount) & "],"
DataStr = DataStr & DataValue(FieldCount) & ","
End If
Next
'Trim last comma
FieldStr = Left(FieldStr, Len(FieldStr) - 1)
DataStr = Left(DataStr, Len(DataStr) - 1)
BuildQuery = "INSERT INTO " & _
strTable & _
"( " & _
FieldStr & _
" )" & _
" VALUES (" & _
DataStr & _
");"
End Function
Private Sub InsertData(strTable As String)
Dim dbs As Database
Set dbs = CurrentDb
On Error GoTo Err_Execute
dbs.Execute BuildQuery(strTable)
dbs.Close
Exit Sub
Err_Execute:
dbs.Close
Resume Next
End Sub
Private Sub InsertError(strError As String, FieldCount As Integer)
Dim dbs As Database
Set dbs = CurrentDb
On Error GoTo Err_Execute
dbs.Execute "INSERT INTO tblImportErrors ([Track ID], [Error]) VALUES ("
& DataValue(0) & ",""" & FieldName(FieldCount) & ":" & strError & """);"
dbs.Close
Exit Sub
Err_Execute:
dbs.Close
Resume Next
End Sub
Private Sub CreateTable(strTable As String)
Dim dbs As Database
Set dbs = CurrentDb
On Error GoTo Err_Execute
'Are there more possible fields as those?
dbs.Execute "CREATE TABLE " & strTable _
& "([Track ID] INTEGER, [Name] TEXT, [Artist] TEXT, [Composer] TEXT,
[Album] TEXT, [Grouping] TEXT, [Genre] TEXT, " _
& " [Kind] TEXT, [Size] INTEGER, [Total Time] INTEGER, [Disc Number]
INTEGER, [Disc Count] INTEGER, " _
& " [Track Number] INTEGER, [Track Count] INTEGER, [Year] INTEGER,
[Date Modified] DATETIME, [Date Added] DATETIME, " _
& " [Bit Rate] INTEGER, [Sample Rate] INTEGER, [Play Count] INTEGER,
[Play Date] INTEGER, [Play Date UTC] DATETIME," _
& " [Rating] INTEGER, [Artwork Count] INTEGER, [Comments] TEXT,
[Season] INTEGER, [Persistent ID] TEXT, [Track Type] TEXT, [Location] TEXT,
" _
& " [File Folder Count] INTEGER, [Library Folder Count] INTEGER);"
dbs.Execute "CREATE INDEX NewIndex ON " & strTable & " ([Track ID]);"
'dbs.Execute "CREATE TABLE tblImportErrors ([Track ID] INTEGER, [Error]
TEXT);"
dbs.Close
Exit Sub
Err_Execute:
dbs.Close
End Sub
Private Sub DropTable(strTable As String)
Dim dbs As Database
Set dbs = CurrentDb
On Error GoTo Err_Execute
dbs.Execute "DROP TABLE " & strTable & ";"
dbs.Close
Exit Sub
Err_Execute:
dbs.Close
Resume Next
End Sub
into a Access 97 Table.
I couldn't find any useful documentation on how to accomplish this through
Access 97 XML classes,
so I created a simple script that gets the job done without using XML. Just
wondering is there an easier way...
----------------------------------------------------------------------------------------------
Note on the code:
Create a form with a button, and assign the Command1_Click() event to it.
Specify the XML name and path.
Not all MP3 tags might be reconized, since this code is based on my personal
7000+ mp3 library.
----------------------------------------------------------------------------------------------
Option Compare Database
Option Explicit
Dim FieldName(30) As String
Dim DataType(30) As String
Dim DataValue(30) As Variant
Private Sub Command1_Click()
On Error GoTo Err_Command1_Click
'DoCmd.Hourglass True
DropTable ("tblImportErrors")
DropTable ("tblTracks")
CreateTable ("tblTracks")
LoadFile ("iTunes Music Library.xml")
'DoCmd.Hourglass False
Exit Sub
Exit_Command1_Click:
Exit Sub
Err_Command1_Click:
Resume Next
End Sub
Private Sub LoadFile(myFile As String)
Dim myLine As String
Dim FieldCount As Integer
Dim Level As Integer
On Error GoTo Err_ProccessFile
Close #1
Open myFile For Input As #1 ' Open file for input.
FieldCount = -1
Level = 0
'Loop until end of file.
Do While Not EOF(1)
Input #1, myLine
'Change Levels up
If Pos(myLine, "<dict>") <> 0 Then
Level = Level + 1
End If
'Change Levels down
If Pos(myLine, "</dict>") <> 0 Then
Level = Level - 1
' If level drops back to 1 exit
If Level = 1 Then
Exit Sub
End If
'If level drops back to 2 insert record
If Level = 2 Then
InsertData ("tblTracks")
'Cleanup Arrays
For FieldCount = 0 To 30
FieldName(FieldCount) = ""
DataType(FieldCount) = ""
DataValue(FieldCount) = ""
Next
FieldCount = -1
End If
End If
'If level is 3 Gather data
If Level = 3 Then
If Pos(myLine, "</key>") <> 0 Then
FieldCount = FieldCount + 1
'DataType
DataType(FieldCount) = GetDataType(myLine)
'FieldName
FieldName(FieldCount) = GetField(myLine)
'DataValue
If DataType(FieldCount) = "date" Then
DataValue(FieldCount) = """" &
GetDateRecord(GetRecord(myLine)) & """"
ElseIf DataType(FieldCount) = "string" Then
DataValue(FieldCount) = """" & GetRecord(myLine) & """"
ElseIf DataType(FieldCount) = "integer" Then
DataValue(FieldCount) = GetRecord(myLine)
End If
End If
End If
Loop
Close #1
Exit Sub
Err_ProccessFile:
Call InsertError(Err.Description, FieldCount)
Resume Next
End Sub
Private Function Pos(myLine As String, Tag As String) As Integer
Pos = InStr(1, myLine, Tag, vbTextCompare)
End Function
Private Function GetField(myLine As String) As String
GetField = Mid(myLine, InStr(1, myLine, "<key>", vbTextCompare) + 5,
InStr(1, myLine, "</key>", vbTextCompare) - 6)
End Function
Private Function GetDataType(myLine As String) As String
Dim C1 As String
C1 = Mid(myLine, InStr(1, myLine, "</key>", vbTextCompare) + 6,
Len(myLine))
GetDataType = Mid(C1, InStr(1, C1, "<", vbTextCompare) + 1, InStr(1, C1,
">", vbTextCompare) - 2)
End Function
Private Function GetRecord(myLine As String) As String
Dim C1 As String
Dim C2 As String
Dim I As Integer
'Convert Double quotes to Single quotes
While InStr(1, myLine, """") > 0
Mid(myLine, InStr(1, myLine, """"), 1) = "'"
Wend
C1 = Mid(myLine, InStr(1, myLine, "</key>", vbTextCompare) + 6,
Len(myLine))
C2 = Mid(C1, InStr(1, C1, ">", vbTextCompare) + 1, Len(myLine))
I = InStr(1, C2, "</")
If I > 0 Then
GetRecord = Left(C2, I - 1)
Else
GetRecord = "" 'does not find the close tag when there is for
example a comma in myLine
End If
End Function
Private Function GetDateRecord(myString As String) As String
'Input 2005-08-11T21:05:05Z'
'Output #2005-08-11 21:05:05#'
Mid(myString, InStr(1, myString, "T"), 1) = " "
Mid(myString, InStr(1, myString, "Z"), 1) = "#"
GetDateRecord = "#" + myString
End Function
Private Function BuildQuery(strTable As String)
Dim FieldCount As Integer
Dim FieldStr As String
Dim DataStr As String
For FieldCount = 0 To 30
If (FieldName(FieldCount) <> "") And (DataValue(FieldCount) <> "")
Then
FieldStr = FieldStr & "[" & FieldName(FieldCount) & "],"
DataStr = DataStr & DataValue(FieldCount) & ","
End If
Next
'Trim last comma
FieldStr = Left(FieldStr, Len(FieldStr) - 1)
DataStr = Left(DataStr, Len(DataStr) - 1)
BuildQuery = "INSERT INTO " & _
strTable & _
"( " & _
FieldStr & _
" )" & _
" VALUES (" & _
DataStr & _
");"
End Function
Private Sub InsertData(strTable As String)
Dim dbs As Database
Set dbs = CurrentDb
On Error GoTo Err_Execute
dbs.Execute BuildQuery(strTable)
dbs.Close
Exit Sub
Err_Execute:
dbs.Close
Resume Next
End Sub
Private Sub InsertError(strError As String, FieldCount As Integer)
Dim dbs As Database
Set dbs = CurrentDb
On Error GoTo Err_Execute
dbs.Execute "INSERT INTO tblImportErrors ([Track ID], [Error]) VALUES ("
& DataValue(0) & ",""" & FieldName(FieldCount) & ":" & strError & """);"
dbs.Close
Exit Sub
Err_Execute:
dbs.Close
Resume Next
End Sub
Private Sub CreateTable(strTable As String)
Dim dbs As Database
Set dbs = CurrentDb
On Error GoTo Err_Execute
'Are there more possible fields as those?
dbs.Execute "CREATE TABLE " & strTable _
& "([Track ID] INTEGER, [Name] TEXT, [Artist] TEXT, [Composer] TEXT,
[Album] TEXT, [Grouping] TEXT, [Genre] TEXT, " _
& " [Kind] TEXT, [Size] INTEGER, [Total Time] INTEGER, [Disc Number]
INTEGER, [Disc Count] INTEGER, " _
& " [Track Number] INTEGER, [Track Count] INTEGER, [Year] INTEGER,
[Date Modified] DATETIME, [Date Added] DATETIME, " _
& " [Bit Rate] INTEGER, [Sample Rate] INTEGER, [Play Count] INTEGER,
[Play Date] INTEGER, [Play Date UTC] DATETIME," _
& " [Rating] INTEGER, [Artwork Count] INTEGER, [Comments] TEXT,
[Season] INTEGER, [Persistent ID] TEXT, [Track Type] TEXT, [Location] TEXT,
" _
& " [File Folder Count] INTEGER, [Library Folder Count] INTEGER);"
dbs.Execute "CREATE INDEX NewIndex ON " & strTable & " ([Track ID]);"
'dbs.Execute "CREATE TABLE tblImportErrors ([Track ID] INTEGER, [Error]
TEXT);"
dbs.Close
Exit Sub
Err_Execute:
dbs.Close
End Sub
Private Sub DropTable(strTable As String)
Dim dbs As Database
Set dbs = CurrentDb
On Error GoTo Err_Execute
dbs.Execute "DROP TABLE " & strTable & ";"
dbs.Close
Exit Sub
Err_Execute:
dbs.Close
Resume Next
End Sub