avdavo
New member
- Joined
- Mar 12, 2019
- Messages
- 5
- Reaction score
- 0
- Points
- 0
- Excel Version(s)
- 2013, 2016
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?
Code:
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