Results 1 to 2 of 2

Thread: Draw XML problem

  1. #1
    Seeker avdavo's Avatar
    Join Date
    Mar 2019
    Excel Version
    2013, 2016

    Draw XML problem

    Register for a FREE account, and/
    or Log in to avoid these ads!

    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?
    Click image for larger version. 

Name:	Capture.PNG 
Views:	33 
Size:	46.0 KB 
ID:	8968
    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", ""
        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
                    StCol = StartCol
                    StartRow = StartRow + 1
                    NextRow = NextRow + 1
            End If
        Next i
        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
        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")
            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
    Attached Thumbnails Attached Thumbnails Click image for larger version. 

Name:	Capture.PNG 
Views:	12 
Size:	43.9 KB 
ID:	8967  

  2. #2
    Acolyte Heyjoe's Avatar
    Join Date
    Jan 2019
    Excel Version
    Why do you have this program in the first place? Couldn't you just save the file as XML data?

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts