Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- <?xml version="1.0" encoding="UTF-8" standalone="yes"?>
- <database
- xmlns="experimentManager"
- xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
- xsi:schemaLocation="experimentManager Database.xsd">
- <conditionTokens>
- ...
- </conditionTokens>
- <participants>
- ...
- </participants>
- </database>
- <?xml version="1.0" encoding="UTF-8" standalone="yes"?>
- <ns1:database xmlns:ns1="experimentManager">
- <ns1:conditionTokens>
- ...
- </ns1:conditionTokens>
- <ns1:participants>
- ...
- </ns1:participants>
- </ns1:database>
- Option Explicit
- Sub ExportXml()
- Dim exportResult As XlXmlExportResult
- Dim exportPath As String
- Dim xmlMap As String
- Dim fileContents As String
- exportPath = RequestExportPath()
- If exportPath = "" Or exportPath = "False" Then Exit Sub
- xmlMap = range("XmlMap")
- exportResult = ActiveWorkbook.XmlMaps(xmlMap).Export(exportPath, True)
- If exportResult = xlXmlExportValidationFailed Then
- Beep
- Exit Sub
- End If
- fileContents = ReadInTextFile(exportPath)
- fileContents = ApplyReplaceRules(fileContents)
- WriteTextToFile exportPath, fileContents
- End Sub
- Function ApplyReplaceRules(fileContents As String) As String
- Dim replaceWorksheet As Worksheet
- Dim findWhatRange As range
- Dim replaceWithRange As range
- Dim findWhat As String
- Dim replaceWith As String
- Dim cell As Integer
- Set findWhatRange = range("FindWhat")
- Set replaceWithRange = range("ReplaceWith")
- For cell = 1 To findWhatRange.Cells.Count
- findWhat = findWhatRange.Cells(cell)
- If findWhat <> "" Then
- replaceWith = replaceWithRange.Cells(cell)
- fileContents = Replace(fileContents, findWhat, replaceWith)
- End If
- Next cell
- ApplyReplaceRules = fileContents
- End Function
- Function RequestExportPath() As String
- Dim messageBoxResult As VbMsgBoxResult
- Dim exportPath As String
- Dim message As String
- message = "The file already exists. Do you want to replace it?"
- Do While True
- exportPath = Application.GetSaveAsFilename("", "XML Files (*.xml),*.xml")
- If exportPath = "False" Then Exit Do
- If Not FileExists(exportPath) Then Exit Do
- messageBoxResult = MsgBox(message, vbYesNo, "File Exists")
- If messageBoxResult = vbYes Then Exit Do
- Loop
- RequestExportPath = exportPath
- End Function
- Function FileExists(path As String) As Boolean
- Dim fileSystemObject
- Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
- FileExists = fileSystemObject.FileExists(path)
- End Function
- Function ReadInTextFile(path As String) As String
- Dim fileSystemObject
- Dim textStream
- Dim fileContents As String
- Dim line As String
- Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
- Set textStream = fileSystemObject.OpenTextFile(path)
- fileContents = textStream.ReadAll
- textStream.Close
- ReadInTextFile = fileContents
- End Function
- Sub WriteTextToFile(path As String, fileContents As String)
- Dim fileSystemObject
- Dim textStream
- Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
- Set textStream = fileSystemObject.CreateTextFile(path, True)
- textStream.Write fileContents
- textStream.Close
- End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement