As with all code generated by ChatGPT, there may be mistakes/errors!
The code works for our song database but it took multiple iterations to discover all the characters that the ChurchSuite import of Planning Center didn't like.
Here is the code:
Sub ExtractAndCombineVersesFromXML()
Dim fso As Object
Dim folderPath As String
Dim xmlDoc As MSXML2.DOMDocument60
Dim xmlNode As MSXML2.IXMLDOMNode
Dim xmlNodes As MSXML2.IXMLDOMNodeList
Dim ws As Worksheet
Dim linesNode As MSXML2.IXMLDOMNode
Dim linesText As String
Dim combinedVerses As String
Dim verseOrder As Variant
Dim verseDict As Object
Dim key As Variant
Dim endIndex As Long
Dim fileName As String
Dim Title As String
Dim outputRow As Long
Dim lastNodeWasBR As Boolean
Dim readableVerseName As String
Dim baseName As String
' Set the folder path where XML files are located
folderPath = "H:\My Drive\XML Files\Non Praise!" ' Change this to your folder path
' Create a new instance of the FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
' Set the worksheet to the active sheet
Set ws = ActiveSheet
' Clear the worksheet before starting
ws.Cells.Clear
' Write headers on the first row
ws.Cells(1, 1).Value = "Id"
ws.Cells(1, 2).Value = "Title"
ws.Cells(1, 3).Value = "CCLI"
ws.Cells(1, 4).Value = "Themes"
ws.Cells(1, 5).Value = "Notes"
ws.Cells(1, 6).Value = "Last Scheduled Date"
ws.Cells(1, 7).Value = "Song Tag 1"
ws.Cells(1, 8).Value = "Arrangement 1 Name"
ws.Cells(1, 9).Value = "Arrangement 1 BPM"
ws.Cells(1, 10).Value = "Arrangement 1 Length"
ws.Cells(1, 11).Value = "Arrangement 1 Notes"
ws.Cells(1, 12).Value = "Arrangement 1 Keys"
ws.Cells(1, 13).Value = "Arrangement 1 Chord Chart"
ws.Cells(1, 14).Value = "Arrangement 1 Chord Chart Key"
ws.Cells(1, 15).Value = "Arrangement 1 Tag 1"
ws.Cells(1, 16).Value = "Arrangement 1 Tag 2"
' Start writing from row 2
outputRow = 2
' Loop through each XML file in the folder
For Each file In fso.GetFolder(folderPath).Files
If LCase(fso.GetExtensionName(file)) = "xml" Then ' Check if the file is an XML file
' Create a new instance of the XML document
Set xmlDoc = New MSXML2.DOMDocument60
' Load the XML file
xmlDoc.async = False
xmlDoc.Load file.Path
' Set the namespace for the XML
xmlDoc.SetProperty "SelectionNamespaces", "xmlns:ns='http://openlyrics.info/namespace/2009/song'"
' Add an ID
ws.Cells(outputRow, 1).Value = outputRow - 1
' Extract the title
Set xmlNode = xmlDoc.SelectSingleNode("//ns:titles/ns:title")
If Not xmlNode Is Nothing Then
Title = CleanText(xmlNode.text)
ws.Cells(outputRow, 2).Value = Title
End If
' Extract the CCLI number
Set xmlNode = xmlDoc.SelectSingleNode("//ns:ccliNo")
If Not xmlNode Is Nothing Then
ws.Cells(outputRow, 3).Value = xmlNode.text
End If
' Extract the songbook information
Set xmlNode = xmlDoc.SelectSingleNode("//ns:songbooks/ns:songbook")
If Not xmlNode Is Nothing Then
If Not xmlNode.Attributes.getNamedItem("entry") Is Nothing Then
ws.Cells(outputRow, 8).Value = xmlNode.Attributes.getNamedItem("name").text & " #" & xmlNode.Attributes.getNamedItem("entry").text
End If
End If
' Extract the verse order if available
Set xmlNode = xmlDoc.SelectSingleNode("//ns:verseOrder")
If Not xmlNode Is Nothing Then
verseOrder = Split(xmlNode.text, " ")
Else
verseOrder = ""
End If
' Extract the lyrics and store them in a dictionary
Set verseDict = CreateObject("Scripting.Dictionary")
Set xmlNodes = xmlDoc.SelectNodes("//ns:verse")
If xmlNodes.Length > 0 Then
For Each xmlNode In xmlNodes
linesText = ""
lastNodeWasBR = False
For Each linesNode In xmlNode.SelectSingleNode("ns:lines").ChildNodes
If linesNode.NodeType = NODE_TEXT Then
linesText = linesText & linesNode.text
lastNodeWasBR = False
ElseIf linesNode.NodeType = NODE_ELEMENT And linesNode.nodeName = "br" Then
If Not lastNodeWasBR Then
linesText = linesText & vbCrLf & vbCrLf
lastNodeWasBR = True
End If
ElseIf linesNode.NodeType = NODE_ELEMENT And linesNode.nodeName = "tag" Then
linesText = linesText & ExtractTagText(linesNode)
lastNodeWasBR = False
End If
Next linesNode
' Clean the text
linesText = CleanText(linesText)
baseName = Left(xmlNode.Attributes.getNamedItem("name").text, 2) ' Get the base name, e.g., "v4"
If verseDict.exists(baseName) Then
verseDict(baseName) = verseDict(baseName) & vbCrLf & vbCrLf & linesText
Else
verseDict.Add baseName, linesText
End If
Next xmlNode
End If
' Combine the verses using the specified order or the order in the XML file
combinedVerses = ""
If IsArray(verseOrder) Then
For Each key In verseOrder
If verseDict.exists(key) Then
readableVerseName = GetReadableVerseName(CStr(key))
combinedVerses = combinedVerses & readableVerseName & vbCrLf & vbCrLf & verseDict(key) & vbCrLf
End If
Next key
Else
For Each key In verseDict.keys
readableVerseName = GetReadableVerseName(CStr(key))
combinedVerses = combinedVerses & readableVerseName & vbCrLf & vbCrLf & verseDict(key) & vbCrLf
Next key
End If
' Remove the last two newlines
combinedVerses = Left(combinedVerses, Len(combinedVerses) - 2)
' Find the index of the copyright symbol (if present)
endIndex = InStrRev(combinedVerses, "©")
If endIndex > 0 Then
' Seek to the left for spaces
Do While endIndex > 1 And Mid(combinedVerses, endIndex - 1, 1) = " "
endIndex = endIndex - 1
Loop
' Remove everything from the found index onwards
combinedVerses = Left(combinedVerses, endIndex - 1)
End If
' Output the combined verses to one cell
ws.Cells(outputRow, 13).Value = combinedVerses
' Move to the next output row
outputRow = outputRow + 1
End If
Next file
' Release the objects
Set fso = Nothing
Set xmlDoc = Nothing
Set xmlNode = Nothing
Set xmlNodes = Nothing
Set ws = Nothing
Set verseDict = Nothing
End Sub
Function CleanText(text As String) As String
text = Replace(text, "’", "'")
text = Replace(text, "‘", "'")
text = Replace(text, "–", "-")
text = Replace(text, """", "'")
text = Replace(text, "“", "'")
text = Replace(text, "”", "'")
text = Replace(text, Chr(151), "-")
Do While Right(text, 2) = vbCrLf
text = Left(text, Len(text) - 2)
Loop
text = Replace(text, vbCrLf & vbCrLf & vbCrLf & vbCrLf, vbCrLf & vbCrLf)
CleanText = text
End Function
Function GetReadableVerseName(verseName As String) As String
Dim readableName As String
Select Case Left(verseName, 1)
Case "v"
readableName = "Verse " & Mid(verseName, 2)
Case "c"
readableName = "Chorus " & Mid(verseName, 2)
Case "e"
readableName = "Ending " & Mid(verseName, 2)
Case Else
readableName = verseName
End Select
GetReadableVerseName = readableName
End Function
Function ExtractTagText(tagNode As MSXML2.IXMLDOMNode) As String
Dim childNode As MSXML2.IXMLDOMNode
Dim tagText As String
Dim lastNodeWasBR As Boolean
tagText = ""
lastNodeWasBR = False
For Each childNode In tagNode.ChildNodes
If childNode.NodeType = NODE_TEXT Then
tagText = tagText & childNode.text
lastNodeWasBR = False
ElseIf childNode.NodeType = NODE_ELEMENT And childNode.nodeName = "br" Then
If Not lastNodeWasBR Then
tagText = tagText & vbCrLf & vbCrLf
lastNodeWasBR = True
End If
ElseIf childNode.NodeType = NODE_ELEMENT Then
tagText = tagText & ExtractTagText(childNode)
lastNodeWasBR = False
End If
Next childNode
ExtractTagText = tagText
End Function
