Draw XML problem

[avdavo]

Good morning. I have a file, which converts Excel to XML. I changed some parts in it /mostly in Excel, no VBA/ and I get an error. Can anyone help?

Public Sub DrawXML()    Dim BENEFIC As Long: BENEFIC = Worksheets("Export").Cells(4, 4).Value
    
    Dim DetID As Integer
    Dim DetName As String
    Dim StartRow As Integer: StartRow = 13
    Dim StRow As Integer: StRow = StartRow
    Dim StartCol As Integer: StartCol = 2
    Dim StCol As Integer: StCol = 2
    Dim HeaderRow As Integer: HeaderRow = 8
    Dim TypeRow As Integer: TypeRow = 10
    Dim ValueRow As Integer: ValueRow = 11
    Dim NextRow As Integer: NextRow = 0
    Dim filename1 As String: filename1 = Range("G2").Text
    Dim CurrentPath As String: CurrentPath = Application.ActiveWorkbook.Path & "\" & filename1 & ".xml"
    
    Dim xDate As Date
    Dim xNum As Long
    
    Dim i As Integer


    Dim objDom As MSXML2.DOMDocument
    Dim objRootElem As MSXML2.IXMLDOMElement
    Dim objRowElem As MSXML2.IXMLDOMElement
    Dim objElem As MSXML2.IXMLDOMElement
    
    On Error GoTo THEERROR
    
    Set objDom = New MSXML2.DOMDocument
    
    Set objRootElem = objDom.createElement("POLICY")
    objRootElem.setAttribute "xmlns:xsi", "http://www.w3.org/2001/XMLSchema-instance"
    objRootElem.setAttribute "CNT", Sheets.Count
    objDom.appendChild objRootElem
    
    For i = 1 To Sheets.Count
        WSheet = Sheets(i).Name
        DetID = Worksheets(WSheet).Cells(5, 3).Value
        DetName = Worksheets(WSheet).Cells(3, 2).Value
        StartRow = StRow
        If WSheet <> "Export" Then
            Do While Worksheets(WSheet).Cells(StartRow, StartCol).Value <> ""
                Set objRowElem = objDom.createElement("ROW")
                objRowElem.setAttribute "RID", (NextRow + 1)
                objRowElem.setAttribute "BENEFIC", BENEFIC
                objRowElem.setAttribute "DETID", DetID
                'objRowElem.setAttribute "DETNAME", DetName
                objRootElem.appendChild objRowElem
                
                Do While Worksheets(WSheet).Cells(ValueRow, StCol).Value <> ""
                    
                    If GetVal(WSheet, TypeRow, StCol) = "DT" And GetVal(WSheet, StartRow, StCol) <> "" Then
                        xDate = GetVal(WSheet, StartRow, StCol)
                    End If
                    
                    If GetVal(WSheet, TypeRow, StCol) = "NM" And GetVal(WSheet, StartRow, StCol) <> "" Then
                        xNum = GetVal(WSheet, StartRow, StCol)
                    End If
                    
                    If GetVal(WSheet, TypeRow, StCol) = "CM_CSTTYPE" Then
                        xNum = GetVal(WSheet, StartRow, StCol)
                    End If
                    
                    If GetVal(WSheet, TypeRow, StCol) = "CB" And GetVal(WSheet, StartRow, StCol) <> "" Then
                        xNum = GetVal(WSheet, StartRow, StCol)
                    End If
                    
                    Call SetNode(objDom, objRowElem, objElem, GetVal(WSheet, ValueRow, StCol), GetVal(WSheet, StartRow, StCol), GetVal(WSheet, HeaderRow, StCol), GetVal(WSheet, TypeRow, StCol))
                    StCol = StCol + 1
                Loop
                StCol = StartCol
                StartRow = StartRow + 1
                NextRow = NextRow + 1
            Loop
        End If
    Next i


ShowDlgSaveAS:
    CurrentPath = Application.GetSaveAsFilename(CurrentPath, _
                "XML Files (*.xml),*.xml", 1, "Save As")
    
    If Dir(CurrentPath) <> "" Then
        If MsgBox(prompt:=Dir(CurrentPath) & " already exists." & vbCrLf & "Do you want to replace it?", Buttons:=vbQuestion + vbYesNo, Title:="RGSInsurance-XML Export") = vbNo Then
            GoTo ShowDlgSaveAS
        End If
    End If
    
    If CurrentPath = "False" Then
        Exit Sub
    End If


    Call XMLToFile(objDom, CurrentPath)
    MsgBox "XML Export Complete Successfully", vbInformation + vbOKOnly, "ABC-XML Export"
    Exit Sub
THEERROR:
    MsgBox "Error: " & Err.Description & " " & Worksheets(WSheet).Cells(ValueRow, StCol), vbCritical + vbOKOnly, "ABC-Error"
End Sub


Public Function GetVal(ByVal xSheet As String, ByVal xRow As Integer, ByVal xCol As Integer) As String
    GetVal = Worksheets(xSheet).Cells(xRow, xCol).Value
End Function


Public Sub SetNode(ByVal DomDoc As MSXML2.DOMDocument, _
                   ByVal ParentElem As MSXML2.IXMLDOMElement, _
                   ByVal Elem As MSXML2.IXMLDOMElement, _
                   ByVal NodeName As String, _
                   ByVal NodeValue As String, _
                   ByVal NodeCaption As String, _
                   ByVal NodeType As String)
    Set Elem = DomDoc.createElement(NodeName)
    If NodeType = "DT" And NodeValue <> "" Then
        Elem.Text = Format(CDate(NodeValue), "dd/mm/yyyy")
    Else
        Elem.Text = NodeValue
    End If
    
    'Elem.setAttribute "NodeCaption", NodeCaption
    'Elem.setAttribute "NodeType", NodeType
    ParentElem.appendChild Elem
End Sub


Public Sub XMLToFile(ByVal xmlDoc As Object, ByVal FileName As String)
Dim wrt As New MXXMLWriter
Dim rdr As New SAXXMLReader
Dim fso As New FileSystemObject
Dim stream As TextStream
Dim sXml As String
Dim btXMLInBytes() As Byte
Dim lFile As Long
Dim fFile As File


    Set rdr.contentHandler = wrt
    Set rdr.dtdHandler = wrt
    Set rdr.errorHandler = wrt
    wrt.indent = True
    wrt.omitXMLDeclaration = False
    wrt.Version = "1.0"
    rdr.Parse xmlDoc
    
    sXml = wrt.output
    sXml = Replace(sXml, "encoding=""UTF-16""", "encoding=""UTF-8""")
    btXMLInBytes = UniStrToUTF8(sXml)
    
    If fso.FileExists(FileName) Then '
        Set fFile = fso.GetFile(FileName)
        fFile.Delete True
    End If
    
    lFile = FreeFile()
    Open FileName For Binary Access Write As lFile
    Put lFile, , btXMLInBytes
    Close lFile
End Sub

 

[Heyjoe]

Why do you have this program in the first place? Couldn't you just save the file as XML data?