Excel to VBA custom helpers

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
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