A personal repository of random information in compensation for a fatigued biological computer
xx
Option ExplicitDim myFile, fileDim intResultFunction valueToXML(value As Variant, elementLabel)' Function wraps value in XML tags per elementLabel' If value is empty then nothing is returned' If value is 'NULL' then an empty XML element is returnedvalueToXML = ""If value <> "" ThenvalueToXML = "<" & elementLabel & ">"If value <> "NULL" Then valueToXML = valueToXML & valuevalueToXML = valueToXML & "</" & elementLabel & ">"End IfEnd FunctionFunction valueDateToXML(value, elementLabel)' Function wraps value in XML tags per elementLabel' If value is empty then nothing is returned' If value is 'NULL' then an empty XML element is returned' if target is a date as per isdate the is formatted as YYYY-MM-DDvalueDateToXML = ""If value <> "" Then' condition should still allow 'NULL' to fall throughIf IsDate(value) Then _value = Year(value) & "-" & _Format(Month(value), "00") & "-" & _Format(Day(value), "00")valueDateToXML = valueToXML(value, elementLabel)End IfEnd FunctionFunction valueToXMLAttribute(value As Variant, attributeLabel) As String' Function creates XML attribute' If value is empty then nothing is returned' If value is 'NULL' then an empty attribute is returnedvalueToXMLAttribute = ""If value <> "" ThenvalueToXMLAttribute = " " & attributeLabel & "="""If value <> "NULL" Then valueToXMLAttribute = valueToXMLAttribute & valuevalueToXMLAttribute = valueToXMLAttribute & """"End IfEnd FunctionFunction concatenateRangeObjectToXML(range As Variant, elementLabel)' Function concatenates the cells in the supplied range & wraps that in XML tags per elementLabel' If range is empty then nothing is returnedDim vArr As VariantDim rows, cols, x, yvArr = rangeDim haveDatahaveData = FalseconcatenateRangeObjectToXML = ""rows = UBound(vArr, 1)cols = UBound(vArr, 2)' Check if any dataFor x = 1 To rowsFor y = 1 To colsIf vArr(x, y) <> "" ThenhaveData = TrueExit ForEnd IfNextIf haveData Then Exit ForNextIf haveData ThenconcatenateRangeObjectToXML = "<" & elementLabel & ">"For x = 1 To rowsFor y = 1 To colsIf vArr(x, y) <> "" Then concatenateRangeObjectToXML = concatenateRangeObjectToXML & vArr(x, y)NextNextconcatenateRangeObjectToXML = concatenateRangeObjectToXML & "</" & elementLabel & ">"End IfEnd FunctionFunction concatenateRange(range As Variant)' Function concatenates the range suppliedDim vArr As VariantDim rows, cols, x, yvArr = rangeconcatenateRange = ""rows = UBound(vArr, 1)cols = UBound(vArr, 2)For x = 1 To rowsFor y = 1 To colsIf vArr(x, y) <> "" Then concatenateRange = concatenateRange & vArr(x, y)NextNextEnd FunctionFunction getMyDocumentsPath() As String' Function returns path to my documents folderDim objFSO As ObjectDim objShell As ObjectDim objFolder As ObjectDim objFolderItem As ObjectConst MY_DOCUMENTS = &H5&Set objFSO = CreateObject("Scripting.FileSystemObject")Set objShell = CreateObject("Shell.Application")Set objFolder = objShell.Namespace(MY_DOCUMENTS)Set objFolderItem = objFolder.SelfgetMyDocumentsPath = objFolderItem.PathEnd FunctionSub XMLOutputMakeFileItems()XMLOutputOpenTargetFileXMLOutputOpenWriteHeadersXMLOutputWriteItemsXMLOutputWriteFooterAndCloseintResult = MsgBox("Cells output to " & myFile, vbOKOnly, "Ready")End SubPrivate Sub XMLOutputOpenTargetFile()' Needs VBA -> Tools -> References -> Microsoft ScriptingDim myFso As New FileSystemObjectmyFile = getMyDocumentsPath() & "\_xmlout.xml"Set file = myFso.CreateTextFile(myFile)End SubPrivate Sub XMLOutputOpenWriteHeaders()file.WriteLine (range("XML_file_top").value)End SubPrivate Sub XMLOutputWriteFooterAndClose()file.WriteLine (range("XML_file_bottom").value)file.CloseEnd SubPrivate Sub XMLOutputWriteItems()Dim rCellrange("XML_testdata_items").SpecialCells(xlCellTypeVisible).SelectFor Each rCell In SelectionIf rCell.value <> "" Then file.WriteLine (rCell.value)Next rCellEnd SubSub ExcelCopyItems()range("Excel_testdata").SpecialCells(xlCellTypeVisible).CopyEnd Sub
xxx