A personal repository of random information in compensation for a fatigued biological computer
xxx
Option Explicit Dim myFile, file Dim intResult Private Function valueToXML(tag, value) ' Function wraps value in XML tags per tag: <tag>value</tag> ' If cell per value parameter is empty then nothing is returned ' If value is 'NULL' then an empty XML element is returned ie <tag/> ' if value is 'EMPTY' then an empty set of tags are returned ie <tag></tag> valueToXML = "" If value <> "" Then valueToXML = "<" & tag If value = "NULL" Then valueToXML = valueToXML & "/>" Else valueToXML = valueToXML & ">" If value <> "EMPTY" Then valueToXML = valueToXML & value valueToXML = valueToXML & "</" & tag & ">" End If End If End Function Function valuesToXML(tag _ , Optional value1 As Variant _ , Optional value2 As Variant _ , Optional value3 As Variant _ , Optional value4 As Variant _ , Optional value5 As Variant _ ) ' Function concatenates values1-5 then wraps in XML tags per tag: <tag>value</tag> ' If concatenated values is empty then an empty string is returned ' If concatenated values is 'NULL' then an empty XML element is returned ie <tag/> ' if concatenated values is 'EMPTY' then an empty set of tags are returned ie <tag></tag> valuesToXML = "" If Not IsMissing(value1) Then valuesToXML = value1 If Not IsMissing(value2) Then valuesToXML = valuesToXML & value2 If Not IsMissing(value3) Then valuesToXML = valuesToXML & value3 If Not IsMissing(value4) Then valuesToXML = valuesToXML & value4 If Not IsMissing(value2) Then valuesToXML = valuesToXML & value5 End If End If End If End If valuesToXML = valueToXML(tag, valuesToXML) End Function Function valueDateToXML(tag, value) ' if value is a date as per inbuilt isdate function then is reformatted as YYYY-MM-DD ' value is then passed to valueToXML for wrapping in tags as necessary valueDateToXML = "" If value <> "" Then ' condition allows 'NULL' & EMPTY to fall through If IsDate(value) Then _ value = Year(value) & "-" & _ Format(Month(value), "00") & "-" & _ Format(Day(value), "00") valueDateToXML = valueToXML(tag, value) End If End Function Function valueToXMLAttribute(attributeLabel, value) As String ' Function returns an XML attribute using attributeLabel="value" ' If cell per value parameter is empty then nothing is returned ' If value is 'NULL' then an empty XML attribute is returned ie 'attrib' ' if value is 'EMPTY' then an XML attribute with an empty value is returned 'attrib=""'empty set of tags are returned ie <tag></tag> valueToXMLAttribute = "" If value <> "" Then valueToXMLAttribute = " " & attributeLabel & "=""" If value <> "NULL" And value <> "EMPTY" Then valueToXMLAttribute = valueToXMLAttribute & value valueToXMLAttribute = valueToXMLAttribute & """" End If End Function Function relationshipItemIDToElement(value) ' Function expects an item identifier element, either an Archway ID 'R..' or a transferItemID (anything else) ' example: ' Archway item: <archwayItemRef archwayRecordID="R56789"/> ' TransferItemId: <itemRef ID="ITM_4444"/> ' ' Overrides: ' If value is 'REMPTY' then an empty archwayItemRef element is returned ie <archwayItemRef archwayRecordID=""/> ' if value is 'EMPTY' then an empty itemRef element is returned ie <itemRef ID=""/> Dim valueUCASE valueUCASE = UCase(value) relationshipItemIDToElement = "" If value <> "" Then If Left(valueUCASE, 1) = "R" Then relationshipItemIDToElement = "<archwayItemRef archwayRecordID=""" Else relationshipItemIDToElement = "<itemRef ID=""" End If If valueUCASE = "REMPTY" Or valueUCASE = "EMPTY" Then relationshipItemIDToElement = relationshipItemIDToElement & """/>" Else relationshipItemIDToElement = relationshipItemIDToElement & value & """/>" End If End If End Function Function concatenateRange(range As Variant) ' Function concatenates the contiguous range supplied ' across then down Dim vArr As Variant Dim rows, cols, x, y vArr = range concatenateRange = "" rows = UBound(vArr, 1) cols = UBound(vArr, 2) For x = 1 To rows For y = 1 To cols If vArr(x, y) <> "" Then concatenateRange = concatenateRange & vArr(x, y) Next Next End Function Function getMyDocumentsPath() As String ' Function returns path to users 'My Documents' folder Dim objFSO As Object Dim objShell As Object Dim objFolder As Object Dim objFolderItem As Object Const MY_DOCUMENTS = &H5& Set objFSO = CreateObject("Scripting.FileSystemObject") Set objShell = CreateObject("Shell.Application") Set objFolder = objShell.Namespace(MY_DOCUMENTS) Set objFolderItem = objFolder.Self getMyDocumentsPath = objFolderItem.Path End Function Sub XMLOutputTestItems() XMLOutputOpenTargetFile XMLOutputOpenWriteHeaders XMLOutputWriteNamedRangeVisibleOnly ("TestItems_XML") If DoesRangeHaveData("TestItems_XML_hasParts") Or DoesRangeHaveData("TestItems_XML_hasComponents") Then file.WriteLine ("<itemRelationships>") XMLOutputWriteNamedRangeVisibleOnly ("TestItems_XML_hasParts") XMLOutputWriteNamedRangeVisibleOnly ("TestItems_XML_hasComponents") file.WriteLine ("</itemRelationships>") End If XMLOutputWriteFooterAndClose intResult = MsgBox("Cells output to " & myFile, vbOKOnly, "Ready") End Sub Sub XMLOutputTestItemsAndTestRelationships() XMLOutputOpenTargetFile XMLOutputOpenWriteHeaders XMLOutputWriteNamedRangeVisibleOnly ("TestItems_XML") If DoesRangeHaveData("TestItems_XML_hasParts") _ Or DoesRangeHaveData("TestItems_XML_hasComponents") _ Or DoesRangeHaveData("TestRelationships_XML_hasParts") _ Or DoesRangeHaveData("TestRelationships_XML_hasComponents") _ Or DoesRangeHaveData("TestRelationships_XML_providesMetadataFor") Then file.WriteLine ("<itemRelationships>") XMLOutputWriteNamedRangeVisibleOnly ("TestItems_XML_hasParts") XMLOutputWriteNamedRangeVisibleOnly ("TestRelationships_XML_hasParts") XMLOutputWriteNamedRangeVisibleOnly ("TestItems_XML_hasComponents") XMLOutputWriteNamedRangeVisibleOnly ("TestRelationships_XML_hasComponents") XMLOutputWriteNamedRangeVisibleOnly ("TestRelationships_XML_providesMetadataFor") file.WriteLine ("</itemRelationships>") End If XMLOutputWriteFooterAndClose intResult = MsgBox("Cells output to " & myFile, vbOKOnly, "Ready") End Sub Private Sub XMLOutputOpenTargetFile() ' Needs VBA -> Tools -> References -> Microsoft Scripting Runtime: enabled Dim myFso As New FileSystemObject myFile = getMyDocumentsPath() & "\_xmlout.xml" Set file = myFso.CreateTextFile(myFile) End Sub Private Sub XMLOutputOpenWriteHeaders() file.WriteLine (range("XML_file_top").value) End Sub Private Sub XMLOutputWriteFooterAndClose() file.WriteLine (range("XML_file_bottom").value) file.Close End Sub Private Sub XMLOutputWriteNamedRangeVisibleOnly(name) Dim rCell 'range(name).SpecialCells(xlCellTypeVisible).Select ' only works on active sheet Application.Goto Reference:=name ' use this as range is on different sheet For Each rCell In Selection ' for each cell in selection goes across then down which is just ' what we need to a each item in turn If rCell.value <> "" Then file.WriteLine (rCell.value) Next rCell End Sub Function DoesRangeHaveData(name) Dim rCell 'range(name).SpecialCells(xlCellTypeVisible).Select ' only works on active sheet Application.Goto Reference:=name ' use this as range is on different sheet DoesRangeHaveData = False For Each rCell In Selection If rCell.value <> "" Then DoesRangeHaveData = True Exit For End If Next rCell End Function Sub ExcelCopyItems() range("TestItems_Excel").SpecialCells(xlCellTypeVisible).Copy End Sub
xxx