Advertisement
Guest User

Untitled

a guest
Oct 24th, 2014
140
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 3.22 KB | None | 0 0
  1. <?xml version="1.0" encoding="UTF-8" standalone="yes"?>
  2. <database
  3. xmlns="experimentManager"
  4. xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
  5. xsi:schemaLocation="experimentManager Database.xsd">
  6. <conditionTokens>
  7. ...
  8. </conditionTokens>
  9. <participants>
  10. ...
  11. </participants>
  12. </database>
  13.  
  14. <?xml version="1.0" encoding="UTF-8" standalone="yes"?>
  15. <ns1:database xmlns:ns1="experimentManager">
  16. <ns1:conditionTokens>
  17. ...
  18. </ns1:conditionTokens>
  19. <ns1:participants>
  20. ...
  21. </ns1:participants>
  22. </ns1:database>
  23.  
  24. Option Explicit
  25.  
  26. Sub ExportXml()
  27. Dim exportResult As XlXmlExportResult
  28. Dim exportPath As String
  29. Dim xmlMap As String
  30. Dim fileContents As String
  31. exportPath = RequestExportPath()
  32. If exportPath = "" Or exportPath = "False" Then Exit Sub
  33. xmlMap = range("XmlMap")
  34. exportResult = ActiveWorkbook.XmlMaps(xmlMap).Export(exportPath, True)
  35. If exportResult = xlXmlExportValidationFailed Then
  36. Beep
  37. Exit Sub
  38. End If
  39. fileContents = ReadInTextFile(exportPath)
  40. fileContents = ApplyReplaceRules(fileContents)
  41. WriteTextToFile exportPath, fileContents
  42. End Sub
  43.  
  44. Function ApplyReplaceRules(fileContents As String) As String
  45. Dim replaceWorksheet As Worksheet
  46. Dim findWhatRange As range
  47. Dim replaceWithRange As range
  48. Dim findWhat As String
  49. Dim replaceWith As String
  50. Dim cell As Integer
  51. Set findWhatRange = range("FindWhat")
  52. Set replaceWithRange = range("ReplaceWith")
  53. For cell = 1 To findWhatRange.Cells.Count
  54. findWhat = findWhatRange.Cells(cell)
  55. If findWhat <> "" Then
  56. replaceWith = replaceWithRange.Cells(cell)
  57. fileContents = Replace(fileContents, findWhat, replaceWith)
  58. End If
  59. Next cell
  60. ApplyReplaceRules = fileContents
  61. End Function
  62.  
  63. Function RequestExportPath() As String
  64. Dim messageBoxResult As VbMsgBoxResult
  65. Dim exportPath As String
  66. Dim message As String
  67. message = "The file already exists. Do you want to replace it?"
  68. Do While True
  69. exportPath = Application.GetSaveAsFilename("", "XML Files (*.xml),*.xml")
  70. If exportPath = "False" Then Exit Do
  71. If Not FileExists(exportPath) Then Exit Do
  72. messageBoxResult = MsgBox(message, vbYesNo, "File Exists")
  73. If messageBoxResult = vbYes Then Exit Do
  74. Loop
  75. RequestExportPath = exportPath
  76. End Function
  77.  
  78. Function FileExists(path As String) As Boolean
  79. Dim fileSystemObject
  80. Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
  81. FileExists = fileSystemObject.FileExists(path)
  82. End Function
  83.  
  84. Function ReadInTextFile(path As String) As String
  85. Dim fileSystemObject
  86. Dim textStream
  87. Dim fileContents As String
  88. Dim line As String
  89. Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
  90. Set textStream = fileSystemObject.OpenTextFile(path)
  91. fileContents = textStream.ReadAll
  92. textStream.Close
  93. ReadInTextFile = fileContents
  94. End Function
  95.  
  96. Sub WriteTextToFile(path As String, fileContents As String)
  97. Dim fileSystemObject
  98. Dim textStream
  99. Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
  100. Set textStream = fileSystemObject.CreateTextFile(path, True)
  101. textStream.Write fileContents
  102. textStream.Close
  103. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement