Enable Microsoft Scripting Runtime with vba within a Public Sub with Public Declarations

dcoker · Nov 7, 2019

I have a Public Sub that has Public declarations as

Code:

Public sdProcess As New Scripting.Dictionary
Public sdHeaders As New Scripting.Dictionary

I would like to automate the activation of Microsoft Scripting Runtime using this code or something similar:

Code:

ThisWorkbook.VBProject.References.AddFromGUID "{420B2830-E718-11CF-893D-00A0C9054228}", 1, 0

The second line of code works great to enable the reference on its own within a standalone sub, but the problem is that I cannot insert this code to enable the reference within the main Public sub code that needs the reference enabled to run due to the Public declarations before the sub.

Is there a way to make this work without having to run the macro to enable the reference, then run the main macro that uses the reference?

Thanks!

RoryA · Nov 7, 2019

Why do you (think you) need to do that, rather than just setting the reference at design time, or simply using late binding?

dcoker · Nov 7, 2019

I have new code that is needed for older files that did not originally have this reference enabled. :/
Roughly 50 files
Trying to save some time for when I go back and fix the old files using the updated code...

RoryA · Nov 7, 2019

Why not just late bind it?

Also, for what it's worth, it's not really considered good practice to use

Code:

Dim ... As New ...

It's better to declare and initialise separately and explicitly.

dcoker · Nov 7, 2019

I'm not sure how to do that - as I am not the person that originally wrote this script.

Code:

Option Explicit

'IMPORTANT: FROM [Tools] [References...] The following must be checked as Active:
'           Visual Basic For Applications
'           Microsoft Excel 16.0 Object Library
'           OLE Automation
'           Microsoft Office 16.0 Object Library
'           Microsoft Scripting Runtime
'           Microsoft Shell Controls And Automation

'Best practice to always have this set
'Option Compare Database

'XML Generator VERSION:
Const mSyncVersion = 3.05 '2019_10_30 Michael


'Last Edited: MAV 2017-07-07 Modified sSiteXML
'             MARK 2018-08-21 Added Properties Check for Older Files
'             MARK 2018-08-21 Added XML Summary
'             MARK 2019-09-30 Adding Section Checks, etc.
'             DCC  2019-10-29 Added Event Status to pull from 'Master'
'             DCC  2019-11-05 Included code to check if Event Status range exists. This range only exists in newer templates.

'DEFINED NAMES that have been defined and used:
'   EVENT_ID
'   JOB
'   PROJECT_ID
'   CLIENT_PM
'   EVENT_DATE
'   FOREMAN
'   TECHNICIAN
'   CIRCUMFERENCE
'   PROPERTIES

Type FileAttributes
    Name As String
'    Size As String
    FileType As String
    DateModified As Date
    DateCreated As Date
'    DateAccessed As Date
'    Attributes As String
'    Status As String
'    Owner As String
    Author As String
'    Title As String
    Subject As String
'    Category As String
End Type

'Moved from ProcessFile for portability.
Public gbInitXML As Boolean
Public sdProcess As New Scripting.Dictionary
Public sdHeaders As New Scripting.Dictionary
Public wkbInProcess As Workbook
Public wkbMaster As Workbook
Public rngCurrent As Range
Public rngMaster As Range
Public gSectionUnitsMultiplier As Integer


Dim ThisFile As FileAttributes
Dim sdProperties As New Scripting.Dictionary
Dim sdOut As New Scripting.Dictionary
Dim sFileSuggestion As String 'Dig Event ID + date/Time
Dim gbCancel As Boolean

Const WORKINGPATH = "" 'Deactivate for batch processing





'SUB:   ExportAllToXML
'PURPOSE: String together all DATA into One XML String then Write to a File
Public Sub ExportAllToXML()
Dim sXML As String 'Will hold entire XML output
Dim i As Integer
Dim sMsg As String


    'ThisFile = GetFileAttributes(Application.Workbooks(1).FullName)
    If gbInitXML = False Then InitXML
    
    ThisFile = GetFileAttributes(wkbInProcess.FullName)
    wkbInProcess.Activate
    
    If wkbInProcess Is Nothing Then
        'Set objWorkbook = Workbooks.Open(Filename:=SourcePath & sFileName, UpdateLinks:=0) ' ActiveWorkbook.FullName
        Set wkbInProcess = ThisWorkbook
    End If
    
        
        
    sFileSuggestion = "C2C_"
    sFileSuggestion = sFileSuggestion & sGetSafeValue(Range("EVENT_ID"), "Number") '.Text can return ### if the column isn't wide enough!
'    sFileSuggestion = sFileSuggestion & Range("JOB").Text 'Cost 2 Coast Job # from COV
'    sFileSuggestion = sSafeName(sFileSuggestion & "_" & Range("PROJECT_ID").Text)
'    sFileSuggestion = Replace(sFileSuggestion, "Project_", "")
'    sFileSuggestion = Replace(sFileSuggestion, "Location", "_Loc_")
'    sFileSuggestion = Replace(sFileSuggestion, "Line_", "")
'    sFileSuggestion = Replace(sFileSuggestion, "M.P.", "MP_")
'    sFileSuggestion = Replace(sFileSuggestion, ".", "_")
    
    For i = 1 To 5
        sFileSuggestion = Replace(sFileSuggestion, "__", "_")
    Next i
    sFileSuggestion = sFileSuggestion & "_" & Format(Now(), "YYYY_MM_DD_HHMM") & ".XML"
    
    HideUnhideWorkpages (True)
'    InsertSectionXPos  'Called in AssignSections
    CreateRanges 'Fixes indication and propertie ranges via hardcoded overwrite. Deactivate or modify when ranges are correct.
    
    AssignSections 'populate sections tab with zero ref and other sections as needed
        
    sXML = "<?xml version=""1.0"" encoding=""utf-8""?>"   'FYI - This is not technically required
    sXML = "<?xml version=""1.0"" encoding=""utf-8""?>"   'FYI - This is not technically required
    bs sXML, "<root>"
    bs sXML, sSyncXML()     ' Key info to identify this file uniquely when/who, etc.
    bs sXML, sSiteXML()        ' Site/Strucute/Location details
    bs sXML, sEventXML()       ' Details about this "inspection event" specificially - differentiates from return digs as the same site
    bs sXML, sNotesXML()       ' General comments
    bs sXML, sPropertiesXML()  ' Inspection Data
    bs sXML, sSectUTCXML()     ' Section and UTC Data
    bs sXML, sGridsXML()       ' Spatial details/grids on the pipe (eg. pit depths, damages locations, etc.)
    '    bs sXML, sSectionsXML()    ' Section Grid Data
    '    bs sXML, sUTCXML()         'UTC Clock Position Data
    bs sXML, "</root>"
    
    WriteStringToXMLFile sXML, sFileSuggestion

    sMsg = "OUTPUT " & sFileSuggestion
    For i = 0 To sdOut.Count - 1
        sMsg = sMsg & vbCrLf & Mid(sdOut.Keys(i) & Space(20), 1, 20) & " = " & sdOut.Items(i)
    Next i

'    MsgBox "Add additional Data Checks/Confirmations and Display Warnings here!"
    MsgBox sFileSuggestion & vbCrLf & vbCrLf & sMsg & vbCrLf & "Sync_Version" & Space(15) & mSyncVersion
    
    HideUnhideWorkpages False

End Sub



Public Function GetFileAttributes(strFilePath As String) As FileAttributes

' Shell32 objects
Dim objShell As Shell32.Shell
Dim objFolder As Shell32.Folder
Dim objFolderItem As Shell32.FolderItem

' Other objects
Dim strPath As String
Dim strFileName As String
Dim i As Integer

    ' If the file does not exist then quit out
    If Dir(strFilePath) = "" Then Exit Function

    ' Parse the file name out from the folder path
    i = InStrRev(strFilePath, "\")
    strFileName = Mid$(strFilePath, i + 1)
    strPath = Left$(strFilePath, i - 1)
    
    ' Set up the shell32 Shell object
    Set objShell = New Shell

    ' Set the shell32 folder object
    Set objFolder = objShell.Namespace(strPath)

    ' If we can find the folder then ...
    If (Not objFolder Is Nothing) Then

        ' Set the shell32 file object
        Set objFolderItem = objFolder.ParseName(strFileName)

        ' If we can find the file then get the file attributes
        If (Not objFolderItem Is Nothing) Then

            GetFileAttributes.Name = objFolder.GetDetailsOf(objFolderItem, 0)
'            GetFileAttributes.Size = objFolder.GetDetailsOf(objFolderItem, 1)
            GetFileAttributes.FileType = objFolder.GetDetailsOf(objFolderItem, 2)
            GetFileAttributes.DateModified = CDate(objFolder.GetDetailsOf(objFolderItem, 3))
            GetFileAttributes.DateCreated = CDate(objFolder.GetDetailsOf(objFolderItem, 4))
'            GetFileAttributes.DateAccessed = CDate(objFolder.GetDetailsOf(objFolderItem, 5))
'            GetFileAttributes.Attributes = objFolder.GetDetailsOf(objFolderItem, 6)
'            GetFileAttributes.Status = objFolder.GetDetailsOf(objFolderItem, 7)
'            GetFileAttributes.Owner = objFolder.GetDetailsOf(objFolderItem, 10)
            GetFileAttributes.Author = objFolder.GetDetailsOf(objFolderItem, 20)
'            GetFileAttributes.Title = objFolder.GetDetailsOf(objFolderItem, 21)
            GetFileAttributes.Subject = objFolder.GetDetailsOf(objFolderItem, 22)
'            GetFileAttributes.Category = objFolder.GetDetailsOf(objFolderItem, 23)

        End If

        Set objFolderItem = Nothing

    End If

    Set objFolder = Nothing
    Set objShell = Nothing

End Function

Function GetFileAuthor(strFilePath As String) As String

Dim fa As FileAttributes

    fa = GetFileAttributes(strFilePath)
    
    GetFileAuthor = fa.Author

End Function
'FUNCTION: sSafeName
'PURPOSE: Return a safe string to use as a filename
' PARAMS: sIn - candidate string for converting
'RETURNS: string stripped of non-standard characters (safe for file name or internet address/ftp send)
'   NOTES: Return String
Function sSafeName(sIn As String) As String
Dim sOut As String
Dim iPos As Integer
Dim iChar As Integer
'46 = period . needed to separate the extension
'95 -- 97-122 a-z plus underscore _ (95) - NOTE that grave `(96) is replaced with _
'65 - 90 A-Z
'45, 47 and 48 - 57 Numbers + PERIOD and Dash OK (47 slash gets replaced with underscore)

    sOut = ""
    For iPos = 1 To Len(sIn)
        iChar = Asc(Mid(sIn, iPos, 1))
        If iChar = 32 Or iChar = 96 Or iChar = 40 Or iChar = 41 Or iChar = 47 Or iChar = 91 Or iChar = 92 Or iChar = 93 Or iChar = 94 Or iChar = 123 Or iChar = 124 Or iChar = 125 Then
            iChar = 95 'change spaces, dashes, parens, slashes to underscore
        End If
        If (iChar > 94 And iChar < 123) Or (iChar > 64 And iChar < 91) Or (iChar > 44 And iChar < 58) Then  'OK
            sOut = sOut & Chr(iChar)
        End If
    Next iPos

    sSafeName = sOut
    
End Function

'SUB:   WriteStringToXMLFile
'PURPOSE: Write output string to XML file
Public Sub WriteStringToXMLFile(sOut As String, Optional sSuggestedName As String = "")

Dim sFile As String
Dim hFree As Integer

    'Show Save As dialog Box
    sFile = Application.GetSaveAsFilename(sSuggestedName, "(*.xml),*.xml", , "Save XML Output File As...")
    If sFile = "False" Or Len(sFile) < 8 Then Exit Sub 'too short to be a valid filename
    'sFile = sSafeName(sFile)    ' user may have added "clever" additions that are "Windows Safe"
                                ' but may choke on FTP Post or CMD file processing, e.g. Ampersand, Spaces, Colon, etc.
    sSuggestedName = sFile 'parameter is updated to allow MsgBox in calling routine to report what the actual filename was
    'Get Free File Handle
    hFree = FreeFile
 
    Open sFile For Output As [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=hFree]#hFree[/URL] 
    Print [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=hFree]#hFree[/URL] , sOut
    Close [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=hFree]#hFree[/URL] 

    '2017-07-07 MAV Save Last Exported Date/Time and File Location/Name
    Worksheets("New XML").Range("XML_LAST_EXPORTED_AS").Value = sFile '2019-09-30 Changed to "New XML" to handle 180### series errors
    Worksheets("New XML").Range("XML_LAST_EXPORTED_ON").Value = Now() '2019-09-30 Changed to "New XML" to handle 180### series errors

End Sub

'SUB: bs - Build String
'Purpose: This is just "code simplifier" - it concatenates an existing string with CR/LF and a new string
'         Makes code easier to read
Public Sub bs(ByRef sString As String, ByVal sAdd As String)
    sString = sString & vbCrLf & sAdd
End Sub

'SUB: bx - Build XML String
'Purpose: This is just a "code simplifier" - it concatenates an existing XML string with CR/LF and a new string, checked for XML safe characters
'         Makes code easier to read
Public Sub bx(ByRef sString As String, ByVal sAdd As String)
    sString = sString & vbCrLf & sSafeXML(sAdd)
    
End Sub

'SUB: AddAttribute - Build String Simple (no cr/lf)
'Purpose: This is just "code simplifier" - it concatenates an existing string with a new XML atribute to an existing string
'         Makes code easier to read
Public Sub AddAttribute(ByRef sString As String, ByVal sAttribute As String, ByVal sValue As String)
sValue = sSafeXML(sValue)
    If sValue > "" Then
        sString = sString & " " & sSafeXML(sAttribute) & "=" & Chr(34) & sValue & Chr(34)
    Else
        Debug.Print sAttribute & " is blank."
    End If
    
End Sub



'Function: sSyncXML
'Purpose: Return XML Formatted file into/metadata used to identify this file uniquely when/who, etc. and differentiate multiple versions over time, etc.
Function sSyncXML() As String
Dim sReturn As String
Dim sDataID As String
Dim sEventId As String

    '2018-04-07 Mark Valente, Added data_id calc
    sEventId = sGetSafeValue(Range("EVENT_ID"), "Number") '.Text can return ### if the column isn't wide enough!
    If sEventId > "" And IsNumeric(sEventId) = True Then
        'Combines the event_id with a datetime stamp so each data_id is sequentially higher and the "newest" one wins during synchronization
        'E.g.   Event_id 170123
        '       Sent 43195 days since 1900   (4/7/2018)
        '       Plus a 4 digit "fractional" day based on seconds elapsed since midnight at 12:01 noon equal to .5007
        '       Yeilds a DATA_ID =   17012343195.5007
        sDataID = Format((CDbl(sEventId) * 100000) + DateDiff("d", "1900-01-01", Now, 1) + (DateDiff("s", Date, Now, 1) / (24# * 60# * 60#)), "###########.####")
    Else
        sDataID = "0"
        MsgBox "Unable to determine the EVENT_ID. Please stop and evaluate XMLGenerator.sSyncXML() code or RANGE('EVENT_ID').VALUE ", vbExclamation, "XMLGenerator Data Error"
    End If
    sReturn = "<SyncXML "
    sdOut("data_id") = sDataID
    AddAttribute sReturn, "data_id", sDataID
    AddAttribute sReturn, "event_id", Format(sEventId, "#####0")  'Unique dig event id -- not the site (so you can go back to the same site later and so they can change the site id which they do all time!)
    AddAttribute sReturn, "initiated_by", Application.UserName  'Who is at the keyboard
    AddAttribute sReturn, "initiated_on", Now() 'When, exactly, was this generated (even if the file datetime stamp changes, this will help)
    AddAttribute sReturn, "initiated_from", Application.Workbooks(1).Name   'Workbook name, might help when debugging issues later after changes and multiple versions propagate
    AddAttribute sReturn, "sync_version", mSyncVersion    'Syncrhonization Interface Version: This should correlate to what PG&E is expecting so that changes in the future can be identified and accounted for
    AddAttribute sReturn, "sync_status", "created" ' Not currently in use - Import system can use this field to mark a file as it is processed. e.g, created/transferred/imported/completed
    sSyncXML = sReturn & " />"
    
End Function

'Function: sSiteXML
'Purpose: Return XML Formatted Site/Strucute/Location details
Function sSiteXML() As String   'Site is AKA Structure
Dim sReturn As String
Dim sSiteID As String
Dim sStation As String

    sStation = Range("station_number").Cells(1, 1).Text
    If UCase(sStation) = "NA" Or UCase(sStation) = "N/A" Then
        sStation = ""
    End If
    
    If bNameExists(ActiveWorkbook, "Raw", "MP") = True Then
        sSiteID = Mid(sGetSafeValue(Range("LINE_NO").Cells(1, 1), "Text") & " @" & sGetSafeValue(Range("MP").Cells(1, 1), "Number") & " " & sStation, 1, 30) 'MAX LENGTH = 30!
    Else
        sSiteID = Mid(sGetSafeValue(Range("LINE_NO").Cells(1, 1), "Text") & " @" & sGetSafeValue(Range("Mile_Point").Cells(1, 1), "Number") & " " & sStation, 1, 30)  'MAX LENGTH = 30!
    End If
    
    

    sdOut("site_id") = sSiteID
    sReturn = "<Structures "    '2017-07-07 Corrected Element name
    AddAttribute sReturn, "structure_id", sSiteID
   'AddAttribute sReturn, "line", Range("PROJECT_ID").Text
   'MAV 2017-07-26 Changed "LINE" output from PROJECT_ID to just LINE_NO
    AddAttribute sReturn, "line", sGetSafeValue(Range("LINE_NO"), "Text")
    AddAttribute sReturn, "company", "PG&E"
    AddAttribute sReturn, "vendor", "C2C"
    AddAttribute sReturn, "structure_status", "BELLHOLE"
    AddAttribute sReturn, "structure_type", "DEH"   'Direct Examination/H-Form
    AddAttribute sReturn, "client_pm", sGetSafeValue(Range("CLIENT_PM"), "Text")
    
    sSiteXML = sReturn & " />"

End Function






'Function: sEventXML
'Purpose: Return XML Formatted
' Details about this "inspection event" specificially - differentiates from return digs as the same site
Function sEventXML() As String
Dim sEventId As String
Dim sTmp As String

Dim rRangeCheck As Range
    

Dim sReturn As String
    sEventId = sGetSafeValue(Range("EVENT_ID"), "Number")
    sdOut("event_id") = sEventId
    
    sReturn = "<Events "
    '********Event Status differs between templates used. DCC 2019-11-05****************
    'This assigns the Event Status as '70-Delivered'
    'if the range is not located within the template
    On Error Resume Next
    Set rRangeCheck = Range("Event_Status")
    On Error GoTo 0
    If rRangeCheck Is Nothing Then
       AddAttribute sReturn, "event_status", "70-Delivered" 'Older Template should already be in status 70.
    Else
    AddAttribute sReturn, "event_status", sGetSafeValue(Range("Event_Status"), "Text") 'DCC 2019-10-29 Event Status is pulled from 'Master' Tab
    End If
    AddAttribute sReturn, "event_id", sEventId
    sTmp = sGetSafeValue(Range("EVENT_DATE"), "Date")
    If IsDate(sTmp) = False Then
        MsgBox "Event Date: " & sTmp & " is not valid. Please correct and re-run."
        Debug.Assert False
    End If
    AddAttribute sReturn, "event_date", sTmp
    AddAttribute sReturn, "event_type", "DEH"
    
    AddAttribute sReturn, "crew", sGetSafeValue(Range("FOREMAN"), "Text")         'DE Foreman
    AddAttribute sReturn, "reader", sGetSafeValue(Range("TECHNICIAN"), "Text")    'DE Technician
    sTmp = Replace(Replace(sGetSafeValue(Range("CIRCUMFERENCE"), "Text"), "'", ""), """", "")
    If Val(sTmp) < 1 Then
        gbCancel = True
        MsgBox "Invalid Circumference Value: " & sTmp
        Stop
    End If
        
    AddAttribute sReturn, "actual_circumference", sTmp 'measured pipe circumference at initial GPS Identified site location
    
    AddAttribute sReturn, "last_edited_by", ThisFile.Author
    AddAttribute sReturn, "last_edited_on", Format(DateAdd("s", 0, ThisFile.DateModified), "YYYY-mm-ddTHH:MM:ss")
 
    'AddAttribute sReturn, "last_edited_by", Application.UserName               'This should be the last edited to the overall event data
    'AddAttribute sReturn, "last_edited_on", Now()                              'This should be the last date/time an event level field was changed, e.g. status
    'AddAttribute sReturn, "last_edited_from", Application.Workbooks(0).Name    'This should be the computer/workstation id that last edited the event level data
    
    sEventXML = sReturn & " />"

End Function

Function sNotesXML() As String

Dim sElement As String
Dim iRow As Integer
Dim rngNotes As Range
Dim sValue As String
Dim sReturn As String
Dim dCreatedOnStart As Date
Dim iNotesCount As Integer

    dCreatedOnStart = ThisFile.DateCreated
    dCreatedOnStart = DateAdd("h", -1 * DatePart("h", dCreatedOnStart), dCreatedOnStart)
    dCreatedOnStart = DateAdd("n", -1 * DatePart("n", dCreatedOnStart), dCreatedOnStart)
    dCreatedOnStart = DateAdd("s", -1 * DatePart("s", dCreatedOnStart), dCreatedOnStart)
    
    sNotesXML = ""

    Set rngNotes = Range("SITE_SUMMARY")   'Much better to use a named Range so that changes in the future don't break this...
    
    For iRow = 1 To rngNotes.Rows.Count
        sElement = "<Notes "
        sValue = rngNotes.Cells(iRow, 1).Text
        AddAttribute sElement, "created_on", Format(DateAdd("s", iRow, dCreatedOnStart), "YYYY-mm-ddTHH:MM:ss")
        AddAttribute sElement, "created_by", ThisFile.Author
        AddAttribute sElement, "last_edited_by", ThisFile.Author
        AddAttribute sElement, "last_edited_on", Format(DateAdd("s", iRow, ThisFile.DateModified), "YYYY-mm-ddTHH:MM:ss")
'        AddAttribute sElement, "note_type", ThisFile.FileType
        
        If sValue <> "Authors:" Then
            If sValue <> "" Then
                iNotesCount = iNotesCount + 1
                AddAttribute sElement, "note", sValue
                sElement = sElement & " />"
                bs sReturn, sElement
            End If
        End If
        
        
    Next
    sdOut("notes_count") = iNotesCount
    
sNotesXML = sReturn
                
'    Debug.Print sLine
    
End Function

' Inspection Data
Function sPropertiesXML() As String
Dim sReturn As String
Dim sElement As String
Dim iCol As Integer
Dim rngProperties As Range
Dim sProperty As String
Dim sValue As String '2019-09-30 Split sValue out to be checked for "NA" in advance
'Mark Valente: 2018-04-07 Expanded the PROPERTIES range to include a TYPE indicator to make GRID, PROPERTY and OTHER identifications easier
Const ROW_TYPE = 1  'PROPERTY or GRID, etc.... anything other than PROPERTY shouldbe ignored here
Const ROW_TITLE = 2
'Const ROW_PROPERTY = 3
'Const ROW_VALUE = 4
Dim ROW_PROPERTY As Integer 'old files are 1 and 2
Dim ROW_VALUE As Integer    'old files are 1 and 2
Dim iPropertiesCount As Integer




    CreateNamedRange "PROPERTIES", "New XML", "R2C1:R5C200", True     '2019_10_04 Added to capture resorted property list.
    Names("Indication_Report_Data").Visible = True



    LoadPropertiesList  'Load current list of valid property names
    Set rngProperties = Range("PROPERTIES")   'Much better to use a named Range so that changes in the future don't break this...

    If rngProperties.Rows.Count = 4 Then
        ROW_PROPERTY = 3
        ROW_VALUE = 4
    Else
        ROW_PROPERTY = 1
        ROW_VALUE = 2
    End If
 
    sElement = "<EventProperties "
 
    sReturn = ""
    
    For iCol = 1 To rngProperties.Columns.Count
        'If rngProperties.Cells(ROW_TYPE, iCol) = "PROPERTY" Then
        sProperty = rngProperties.Cells(ROW_PROPERTY, iCol).Text
        sValue = rngProperties.Cells(ROW_VALUE, iCol).Text
        '2019-09-30 Additional Code to identify numeric requirements and confirm values should be added here! - strip out "NA"
        If sdProperties(sProperty) = "Y" And sValue <> "NA" And sValue <> "" Then
            bs sReturn, sElement
            AddAttribute sReturn, "property", sProperty
            AddAttribute sReturn, "value", sValue
            AddAttribute sReturn, "last_edited_on", Format(DateAdd("s", iCol, ThisFile.DateModified), "YYYY-mm-ddTHH:MM:ss")
            'AddAttribute sXML, "last_edited_by", ThisFile.Author
            'AddAttribute sXML, "last_edited_from", "LAPTOP/WORKSTATION ID"
            sReturn = sReturn & " /> " ' End the property
            iPropertiesCount = iPropertiesCount + 1
        End If
    
    Next
    
    bs sReturn, sElement
    AddAttribute sReturn, "property", "DEH_Attach_NDE_Workbook"
    AddAttribute sReturn, "value", ThisFile.Name
    AddAttribute sReturn, "last_edited_on", Format(DateAdd("s", iCol, ThisFile.DateModified), "YYYY-mm-ddTHH:MM:ss")
    sReturn = sReturn & " /> "
    

    

    sPropertiesXML = sReturn
    sdOut("properties_count") = iPropertiesCount
    'E.G. <EventProperties property="DEH_HEADER_Installation_Year" value="1988" last_edited_by="John.Doe@CoastNDE.com" last_edited_on="2017-07-01T10:52:00" last_edited_from="CNDE123"/>

End Function


Sub AssignSections()

Dim sSection As String
Dim iRow As Integer
Dim iColumn As Integer
Dim iLowColumn As Integer
Dim iMaxCol As Integer
Dim iSection As Integer
Dim iNextSection As Integer
Dim rngSections As Range
Dim nThisPos As Single
Dim nLastMin As Single
Dim nMinPos As Single
Dim iZeroRefColumn As Integer
Dim sZeroRef As String ' E.G. SX-001
Dim bAddZeroRefSection As Boolean
Dim iLastNegative As Integer
Dim sTmp As String

InsertSectionXPos

'column 1: labels
'row 1: SX-
'row 2: pos_x
'column 2: ZERO_REF
'row 27: SUB_TYPE
'row 28: REFERENCE_ID
Const ROW_SECTION_ANOMALY_ID = 1
Const ROW_SECTION_SEC_POS_X = 2
Const ROW_SECTION_POS_X = 3
Const ROW_SECTION_POS_Y = 4
Const ROW_SECTION_SUB_TYPE = 21         'Testing value -1 to solve overwrite issue
Const ROW_SECTION_REFERENCE_ID = 22     'Testing value -1 to solve overwrite issue
Const ROW_SECTION_INDICATION = 5
Const ROW_SECTION_CIRCUMFERENCE = 6
Const ROW_SECTION_DIM_Z = 7
Const ROW_SECTION_NOTES = 8
    
    

    Set rngSections = Range("Sections_UTC_Data") 'NOTE: Column1 is hidden with labels, Column  2 is hidden and left blank, first Section is Column 3
     
    
    'FIRST DETERMINE MAX COLUMNS AND ZERO_REF
    iMaxCol = rngSections.Columns.Count 'can be changed later to skip blanks on the right
    nLastMin = -999999
    nMinPos = 999999
    iNextSection = 0
    For iColumn = 3 To iMaxCol
        If rngSections(2, iColumn).Text = "" Then 'END OF SECTIONS
            iMaxCol = iColumn - 1
            Exit For
        Else
            sTmp = rngSections(2, iColumn).Text '2019-09-30 Changed from "presumed numeric"
            nThisPos = Val(sTmp)
            'nThisPos = rngSections(2, iColumn).Value
            If nThisPos < 0 Then 'BEFORE THE ZERO_REF
                iNextSection = iNextSection + 1
                iLastNegative = iColumn
            End If
            If nThisPos = 0 Then 'FOUND A NORMAL ZERO_REF with pos_x = 0!
                iNextSection = iNextSection + 1
                nMinPos = nThisPos
                iZeroRefColumn = iColumn
            End If
            If nThisPos > 0 And nThisPos < nMinPos Then 'AFTER THE ZERO REF
                nMinPos = nThisPos
                iZeroRefColumn = iColumn
            End If
        End If
    Next iColumn
    
    If nMinPos <> 0 Then 'NO ZERO REF SECTION IDENTIFIED... CREATE ONE
    
        If 1 = 1 Then
            MsgBox "A section assignment error has prevented the XML file from generating sucessfully. Please enter section information including start-of-inspection position, and zero reference (if diffrent)."
            Stop
        End If
    
        Debug.Print "Creating ZERO_REF Section"
        bAddZeroRefSection = True
        iMaxCol = iMaxCol + 1
        iZeroRefColumn = iMaxCol
        iNextSection = iNextSection + 1
        rngSections.Cells(ROW_SECTION_SEC_POS_X, iZeroRefColumn).Value = 0
        
        'COPY LONG SEAM WELD POSITION
        rngSections.Cells(ROW_SECTION_POS_Y, iZeroRefColumn) = rngSections.Cells(ROW_SECTION_POS_Y, iLastNegative).Text
        
        'COPY LONG SEAM WELD TYPE - INDICATION
        rngSections.Cells(ROW_SECTION_INDICATION, iZeroRefColumn) = rngSections.Cells(ROW_SECTION_INDICATION, iLastNegative).Text
        
        'COPY CIRCUMERENCE
        rngSections.Cells(ROW_SECTION_CIRCUMFERENCE, iZeroRefColumn) = rngSections.Cells(ROW_SECTION_CIRCUMFERENCE, iLastNegative).Text
    
        'COPY NOMINAL WALL THICKNESS
        rngSections.Cells(ROW_SECTION_DIM_Z, iZeroRefColumn) = rngSections.Cells(ROW_SECTION_DIM_Z, iLastNegative).Text
        
'        MsgBox "Please check and ensure that all nominal wall thickness are recorded as numeric values."
'        Debug.Assert False
        
        rngSections.Cells(ROW_SECTION_NOTES, iZeroRefColumn) = "Created ZERO_REF Section"

    End If
    rngSections.Cells(ROW_SECTION_SUB_TYPE, iZeroRefColumn) = "ZERO-REF"
    sZeroRef = "SX-" & Right("000" & iNextSection, 3)
    rngSections.Cells(ROW_SECTION_ANOMALY_ID, iZeroRefColumn) = sZeroRef
    rngSections.Cells(ROW_SECTION_REFERENCE_ID, iZeroRefColumn) = sZeroRef
   
    
    nLastMin = -999999
    nMinPos = 999999
    iNextSection = 1
    For iSection = 3 To iMaxCol
        nMinPos = 999999
        
        For iColumn = 3 To iMaxCol
            sTmp = rngSections(2, iColumn).Text '2019-09-30 Changed from "presumed numeric"
            nThisPos = Val(sTmp)
            'nThisPos = rngSections(2, iColumn).Value
            If nThisPos < nMinPos And nThisPos > nLastMin Then
                iLowColumn = iColumn
                nMinPos = nThisPos
            End If
            If nThisPos <> 0 Then
                rngSections.Cells(ROW_SECTION_SUB_TYPE, iColumn) = "LOCAL-REF"
                rngSections.Cells(ROW_SECTION_REFERENCE_ID, iColumn) = sZeroRef
            End If
        Next iColumn
        rngSections.Cells(ROW_SECTION_ANOMALY_ID, iLowColumn) = "SX-" & Right("000" & iNextSection, 3)
        
        nLastMin = nMinPos
        iNextSection = iNextSection + 1
        
    Next iSection
    
    Debug.Print "Section Updated"
    

End Sub


Sub InsertSectionXPos()

Dim rngSections As Range

    Worksheets("Sections").Activate
    Set rngSections = Range("Sections_UTC_Data")
    
    If rngSections(2, 1).Value <> "Section_pos_x005F_x" Then

    
        Rows("9:9").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Range("A9") = "Section Start Distance from Zero Ref (inches)"
        Range("A9").Interior.Pattern = xlNone
        Range("B9") = "Section_pos_x005F_x"
    
        'Rows.EntireRow.Hidden = False
        'Columns.EntireColumn.Hidden = False
    
    End If
    
    
 'Debug.Print "Test"
    'If XPos_Section row does not exist then
    
    '    rngSections(2, 1).Resize(iInsertOffset).Insert Shift:=xlDown
    '    rngSections(2, 1).Resize(1).Insert Shift:=xlDown
        
    'End If

End Sub


Function sSectUTCXML() As String

Dim sSectReturn As String
Dim sUTCReturn As String
Dim iRow As Integer
Dim iColumn As Integer
Dim rngGrids As Range
Dim rngUTC As Range
Dim sGridType As String
Dim sLine As String
Dim sClock As String
Dim nYpos As Single
Dim iSectionsCount As Integer
Dim nDimZ As Single
Dim nPosX As Single
Dim sRefID As String
Dim iGridPoint As Integer '2019-10-30 UTC Grid points consecutive, not 1-12 repeat.


Dim sUTCNotes(1 To 12) As String
sUTCNotes(1) = "UT Wall Thickness-TDC"
sUTCNotes(2) = "UT Wall Thickness-1 O'clock"
sUTCNotes(3) = "UT Wall Thickness-2 O'clock"
sUTCNotes(4) = "UT Wall Thickness-3 O'clock"
sUTCNotes(5) = "UT Wall Thickness-4 O'clock"
sUTCNotes(6) = "UT Wall Thickness-5 O'clock"
sUTCNotes(7) = "UT Wall Thickness-6 O'clock"
sUTCNotes(8) = "UT Wall Thickness-7 O'clock"
sUTCNotes(9) = "UT Wall Thickness-8 O'clock"
sUTCNotes(10) = "UT Wall Thickness-9 O'clock"
sUTCNotes(11) = "UT Wall Thickness-10 O'clock"
sUTCNotes(12) = "UT Wall Thickness-11 O'clock"


'    If MsgBox("Add sections and property headers." & vbCrLf & "Use <CTRL> <BREAK> to pause" & vbCrLf & vbCrLf & "Are the axial position values entered in Inches?", vbYesNo, "At Status 40") = vbNo Then
'        gSectionUnitsMultiplier = 12
'    Else
'        gSectionUnitsMultiplier = 1
'
'    End If


    sSectUTCXML = ""
    Set rngGrids = Range("Sections_UTC_Data")
    
    For iColumn = 2 To rngGrids.Columns.Count
        If rngGrids(2, iColumn) > "" Then
            sLine = "<GridPoints "
            AddAttribute sLine, "grid_type", "SX"                       'Hardcode section UTC name?
            AddAttribute sLine, "anomaly_id", rngGrids(1, iColumn) 'CODE ADDED HERE DO DETERMINE RELITIVE SECTION NUMBER
            AddAttribute sLine, "grid_point", Right(rngGrids(1, iColumn), 2)
            
            'AddAttribute sLine, "sub_type", rngGrids(21, iColumn)       'Hardcode section UTC name?
            AddAttribute sLine, "reference_id", rngGrids(22, iColumn)
            'N/A, reference_date    smalldatetime
            'N/A, local_x           real
            
            nPosX = nGetSafeNumber(rngGrids(2, iColumn), 0) * gSectionUnitsMultiplier 'Multiplier handles inches vs feet
            
            AddAttribute sLine, "pos_x005F_x", nPosX
            AddAttribute sLine, "pos_y", sClockToInches(rngGrids(4, iColumn).Text, rngGrids(6, iColumn).Text)
            AddAttribute sLine, "indication", rngGrids(5, iColumn)
                    
            AddAttribute sLine, "dim_y", rngGrids(6, iColumn)
            AddAttribute sLine, "dim_z", rngGrids(7, iColumn)
    
            AddAttribute sLine, "notes", rngGrids(8, iColumn)
            
            AddAttribute sLine, "last_edited_by", ThisFile.Author
            AddAttribute sLine, "last_edited_on", Format(DateAdd("s", 0, ThisFile.DateModified), "YYYY-mm-ddTHH:MM:ss")
            
            sLine = sLine & " />"
            bs sSectReturn, sLine
            iSectionsCount = iSectionsCount + 1
        End If
    Next iColumn
    
    sdOut("sections_count") = iSectionsCount    'Actual Sections Count
    
    Set rngUTC = Range("UTC_Sections")
    iSectionsCount = 0
    iGridPoint = 0
    For iColumn = 2 To rngGrids.Columns.Count
        If rngGrids(2, iColumn) > "" Then
            For iRow = 1 To rngUTC.Rows.Count
                iGridPoint = iGridPoint + 1
                sLine = "<GridPoints "
                AddAttribute sLine, "grid_type", "UTC"
                AddAttribute sLine, "anomaly_id", rngGrids(1, iColumn)
                'no sub atribute type recorded
                AddAttribute sLine, "grid_point", iGridPoint
                
                sRefID = rngGrids(22, iColumn)
                If Len(sRefID) <> 6 Or Mid(sRefID, 1, 2) <> "SX" Then
                    MsgBox "Section " & iColumn & " UTC Reference ID does not match expected format: " & sRefID & vbCrLf & "Please revise and reprocess file."
                    Stop
                End If
                
                
                AddAttribute sLine, "reference_id", sRefID
                
               
                nPosX = nGetSafeNumber(rngGrids(3, iColumn), 0) * gSectionUnitsMultiplier 'Multiplier handles inches vs feet '2019_10_20 Value pulled from eighth row before. Unknown reason.
                AddAttribute sLine, "pos_x005F_x", nPosX
                
                nYpos = sClockToInches(Right(rngUTC(iRow, 1).Text, 5), rngGrids(6, iColumn).Text)
'                sClock = Right(rngUTG(iRow, 1), 5).Value
'                nYPos = Val(Replace(Replace(Mid(sClock, 1, 2), ":", ""), "12", "0")) + (Val(Replace(Mid(sClock, 3), ":", "")) / 60#)
'                nYPos = (nYPos * rngGrids(5, iColumn)) / 12
                AddAttribute sLine, "pos_y", CInt(nYpos)
                    
                'AddAttribute sLine, "dim_y", rngGrids(5, iColumn)
                nDimZ = nGetSafeNumber(rngUTC(iRow, iColumn + 1).Value, 0) 'Why is this " + 1 "
                If nDimZ > 10 Then 'should be decimal
                    nDimZ = nDimZ / 1000
                End If
                AddAttribute sLine, "dim_z", nDimZ
                
                AddAttribute sLine, "notes", sRefID & " " & sUTCNotes(iRow)
                
                AddAttribute sLine, "last_edited_by", ThisFile.Author
                AddAttribute sLine, "last_edited_on", Format(DateAdd("s", 0, ThisFile.DateModified), "YYYY-mm-ddTHH:MM:ss")
                
                sLine = sLine & " />"
                
                If nDimZ > 0 Then
                    iSectionsCount = iSectionsCount + 1
                    bs sUTCReturn, sLine
                End If

            Next iRow
        End If
    Next iColumn

    sdOut("UTC_count") = iSectionsCount

sSectUTCXML = sSectReturn & vbCrLf & sUTCReturn

End Function

Function sClockToInches(sClock As String, sCirc As String) As String

Dim nCirc As Double
Dim nYpos As Double

If IsNumeric(sCirc) = False Then
    MsgBox "Invalid or missing circumference data. Unable to convert " & sClock & " to inches.", vbOKOnly + vbInformation, "Invalid Data"
    sClockToInches = "ERROR"
    Application.Worksheets("Sections").Activate
    End 'STOP ALL CODE !!!
    Exit Function
End If

nCirc = CDbl(sCirc)


nYpos = Val(Replace(Replace(Mid(sClock, 1, 2), ":", ""), "12", "0")) + (Val(Replace(Mid(sClock, 3), ":", "")) / 60#)
nYpos = (nYpos * nCirc) / 12

sClockToInches = nYpos

End Function

'FUNCTION: sGetIndication
'PURPOSE: Return TCAT Anomily ID Prefix
' PARAMS: sInindicationType - C2C Indication type from (Indication Type See Legend, Indication Report)
'RETURNS: String with safe TCAT grid Type Anomaly ID Prefix
'   NOTES: Uses Range("TCAT_Indication_Legend")
Function sGetIndication(ByVal sIndicationType As String, ByRef sGridType As String) As String
Dim sOut As String
Dim iRow As Integer
Dim rngLookup As Range


    sOut = ""
    
    Set rngLookup = Range("TCAT_Indication_Legend")
    
    For iRow = 1 To rngLookup.Rows.Count
        If UCase(sIndicationType) = UCase(rngLookup.Cells(iRow, 1)) Then
            sOut = rngLookup.Cells(iRow, 4)
            sGridType = Replace(rngLookup.Cells(iRow, 3), "-", "")
            Exit For
        End If
    Next


    sGetIndication = sOut
    
End Function
                    
' Spatial details/grids on the pipe (eg. pit depths, damages locations, etc.)
'GRIDS identify each item with an anomaly type, #, Axial and Circumferantial location, X-width, Y-height and Z-depth (if applicable)
'      Further fields indicate indication type, notes, last_edited, etc.
                    
' Spatial details/grids on the pipe (eg. pit depths, damages locations, etc.)
'GRIDS identify each item with an anomaly type, #, Axial and Circumferantial location, X-width, Y-height and Z-depth (if applicable)
'      Further fields indicate indication type, notes, last_edited, etc.
Function sGridsXML() As String

Dim sReturn As String
Dim sElement As String
Dim iRow As Integer
Dim iColumn As Integer
Dim rngGrids As Range
Dim sValue As String
Dim sGridType As String
Dim sLine As String
Dim sIndicationType As String
Dim sAnamolyIDPrefix As String
Dim nXFeet As Single
Dim sClock As String
Dim nCircumference As Single
Dim nYpos As Single
Dim sNotes As String ' Notes, interactions and decision all strung together
Dim iGridsCount As Integer

Dim COL_Indication_Type As Integer
Dim COL_Indication_number As Integer
Dim COL_pos_x As Integer
Dim COL_indication As Integer
Dim COL_clock As Integer
Dim COL_dim_x As Integer
Dim COL_dim_y As Integer
Dim COL_dim_z As Integer
Dim COL_notes As Integer
Dim COL_interactions As Integer
Dim COL_engineering_decision As Integer
'Depth (%)
'Actual Wall Thickness (mils)
'Longseam
'Station


    CreateNamedRange "Indication_Report_Data", "Indication Table", "R7C3:R257C121", True     '2019_10_03 Added due to high error rate when importing indications.
    Names("Indication_Report_Data").Visible = True
    
    sGridsXML = ""
    Set rngGrids = Range("Indication_Report_Data")   'Much better to use a named Range so that changes in the future don't break this...
    ConfirmOrFixRangeHeaders rngGrids, "Indication Type See Legend"     'If the named range doesn't include the headers above then extend the range to include them
    COL_Indication_Type = iGetColumnFromHeader(rngGrids, "Indication Type See Legend", "")
    COL_Indication_number = iGetColumnFromHeader(rngGrids, "Indication I.D. Number", "") 'Indication I.D. Number

    COL_pos_x = iGetColumnFromHeader(rngGrids, "Dist. From Ref", "")
    COL_clock = iGetColumnFromHeader(rngGrids, "Clock", "")
    COL_dim_x = iGetColumnFromHeader(rngGrids, "Length", "")
    COL_dim_y = iGetColumnFromHeader(rngGrids, "Width", "")
    COL_dim_z = iGetColumnFromHeader(rngGrids, "Depth*mils", "Depth (in. mils)")
    COL_interactions = iGetColumnFromHeader(rngGrids, "Interactions", "")
    COL_notes = iGetColumnFromHeader(rngGrids, "Notes", "")
    COL_engineering_decision = iGetColumnFromHeader(rngGrids, "Decision", "")
    
    nCircumference = Val(Replace(Replace(sGetSafeValue(Range("CIRCUMFERENCE"), "Text"), "'", ""), """", ""))
    
'    ThisFile = GetFileAttributes(Application.Workbooks(1).FullName)
    'TCAT_Indication_Legend
'NEED TO ADD WHILE iRow <> "" To not get blank values
    
    For iRow = 2 To rngGrids.Rows.Count 'MARK - adjusted to expect Header Row
        sIndicationType = rngGrids.Cells(iRow, COL_Indication_Type).Text
        If sIndicationType <> "" Then
            sLine = "<GridPoints "
            sAnamolyIDPrefix = sGetIndication(sIndicationType, sGridType)
            
            If sAnamolyIDPrefix = "" Then
                MsgBox "No indication lookup listed for Indication type '" & sIndicationType & "'.", vbOKOnly + vbInformation, "Skipping Indication"
            End If
            
            If sAnamolyIDPrefix <> "N/A" And sAnamolyIDPrefix <> "" Then
            
                AddAttribute sLine, "grid_type", sGridType
                    
                AddAttribute sLine, "anomaly_id", sAnamolyIDPrefix & rngGrids.Cells(iRow, COL_Indication_number).Text     '.Text returns formated value with leading zeros
                AddAttribute sLine, "grid_point", Val(rngGrids.Cells(iRow, COL_Indication_number).Text)
                
                nXFeet = Val(rngGrids.Cells(iRow, COL_pos_x).Text) * 12
                AddAttribute sLine, "pos_x005F_x", nXFeet
                
                sClock = rngGrids.Cells(iRow, COL_clock).Text
                nYpos = Val(Replace(Replace(Mid(sClock, 1, 2), ":", ""), "12", "0")) + (Val(Replace(Mid(sClock, 3), ":", "")) / 60#)
                nYpos = (nYpos * nCircumference) / 12
                AddAttribute sLine, "pos_y", sNum(CInt(nYpos))
                
                AddAttribute sLine, "indication", sIndicationType
                        
                AddAttribute sLine, "dim_x005F_x", sNum(rngGrids.Cells(iRow, COL_dim_x).Text)
                AddAttribute sLine, "dim_y", sNum(rngGrids.Cells(iRow, COL_dim_y).Text)
                
'                AddAttribute sLine, "dim_z", sNum(rngGrids.Cells(iRow, COL_dim_z).Text)
                AddAttribute sLine, "dim_z", sCheckMills(sNum(rngGrids.Cells(iRow, COL_dim_z).Text))
                
                sNotes = rngGrids.Cells(iRow, COL_notes).Text
                If COL_interactions > 0 And rngGrids.Cells(iRow, COL_interactions).Text > "" Then
                    sNotes = "INTERACTIONS: " & rngGrids.Cells(iRow, COL_interactions).Text & " NOTES: " & sNotes
                End If
                If COL_engineering_decision > 0 And rngGrids.Cells(iRow, COL_engineering_decision).Text > "" Then
                    sNotes = sNotes & " ENG DECISION: " & rngGrids.Cells(iRow, COL_engineering_decision).Text
                End If
                
                AddAttribute sLine, "notes", sNotes
        
                AddAttribute sLine, "last_edited_by", ThisFile.Author
                AddAttribute sLine, "last_edited_on", Format(DateAdd("s", iRow, ThisFile.DateModified), "YYYY-mm-ddTHH:MM:ss")
    
                sLine = sLine & " />"
                iGridsCount = iGridsCount + 1
                bs sReturn, sLine
                
                'Debug.Print sReturn
                
            End If
        End If
    
    Next
    'Debug.Print sReturn
    sdOut("Grid Points") = iGridsCount
sGridsXML = sReturn


'GRID TYPES:     UTC: 12 Clock Position UTs taken for each section                          comes from UT ATS, UT Thickness Report
               ' UTG: 12x12 Internal UT Grid                                                comes from H6, Internal Corrosion wall loss grid
               ' SX: Section, each section is delinated/defined by a Girth Weld             derived from RAW,P91 and P93
               ' EC: External Corrosion Cell                                                comes from Indication Table, Indication_Report_Data(named range)
               ' CD: Coating Damage                                                         comes from Indication Table, Indication_Report_Data(named range)
               ' MD: Mechanical Damage, Dent, Gouge, Scrape etc. (anything non-corrosion)   comes from Indication Table, Indication_Report_Data(named range)
               ' MP: Mag Particle/Wet Flur/Linear Indication                                comes from Indication Table, Indication_Report_Data(named range)
               
               'ALL OTHER TYPES ARE N/A
               
               ' PH: Photo Log entry for extra photos
               ' RP: Repair
               ' RC: Recoat (for very long digs where the recoat takes place over a period of days with possible variations in otherwise one-to-one infor

'GRID DETAILS:    grid_type (as above)
                ' grid_point sequential numeric indicator, e.g. 1, 2, 3,
                ' anomaly_id combination of grid_type and grid_point, e.g. EC-001 is External Corrosion Cell [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 
                ' pos_x Axial Location, in inches, from the ZERO_REF point (positive or negative)
                ' pos_y Circumferential location, in inches, from Top Dead Center (NOTE: While this CAN be converted to O'Clock by formula with known circumference, DO NOT SEND O'clock, it is not a good value for any math/formula based validations)
                ' dim_x, dim_y, dim_z  legth, width, depth
                ' indication is key code Drop Down List that varies by Grid Type
                    '    grid_type Indication
                    '    CD Disbonded
                    '    CD Holidays
                    '    CD Other
                    '    CD  Rock Impression
                    '    CD  Root Impression
                    '    CD  Soil Stresses
                    '    EC General
                    '    EC  Girth Weld
                    '    EC Localized
                    '    EC Seam
                    '    MD  Arc Burn
                    '    MD Crack Like Indication
                    '    MD Dent
                    '    MD Gouge
                    '    MD Other
                    '    MD Scrape
                    '    MD  Weld Splatter
                    '    MP Colony
                    '    MP Multiple
                    '    MP Other
                    '    MP Singular
                    '    RC  Bar-Rust 235
                    '    RC  Canusa HBE 95G
                    '    RC  Dev Grip 238
                    '    RC  Dev Tar 247
                    '    RC  PE Tape
                    '    RC  Powercrete J
                    '    RC  Protal 7200
                    '    RC  Scotchkote 323
                    '    RC  Tapecoat 20
                    '    RC  Wax Tape
                    '    RP  Armor Plate
                    '    RP Buffing
                    '    RP Can
                    '    RP  Filler Metal
                    '    RP  Metallic Sleeve
                    '    RP N / A
                    '    RP  Non-metallic Sleeve
                    '    RP Other
                    '    RP Replace
                    '    SX  AO Smith
                    '    SX DSAW
                    '    SX ERW
                    '    SX Flash
                    '    SX Lap
                    '    SX N / A
                    '    SX SMLS
                    '    SX Spiral
                    '    SX SSAW
                'grid_orientaion - one or negative one indicator, identifies if the Grid Columns are oriented with the flow (getting farther away from the upstream edge) or against the flow (getting closer to the upstream edge)
                'grid_size - in decimal inches (almost ALWAYS 1.0 inch for PG&E but .5 or .25, etc. are possible)
                'lattitude -- of section start (Girth Weld)
                'longitude -- of section start (Girth Weld)
                'Notes -- free text up to 255 characters

    
'E.G. Here are the 12 Clock Position readings, UTCs, taken on the first section of pipe
'Notes: SX-001 is "section [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] "
'       pos_x is the Axial position and generaly all clock positions are taken at the same axial position within a section - decimal value is expected, but exponential notation is not necessary
'          WHY is it called pos_x005F_x if the field name is pos_x -- good question, SQL XML export automatically "fixes" certain conflicts and anything "_x" is a considered the beginning of an escape so it is then, itself, escaped.
'       pos_y is the circumferential position or "inches from top dead center" -- exponential notation is not necessary
'<GridPoints grid_type="UTC" anomaly_id="SX-001" grid_point="1" pos_x005F_x="5.00" pos_y="0.0000000e+000" dim_z="1.98" notes="SX-001 UT Wall Thickness-TDC" last_edited_by="John.Doe@CoastNDE.com" last_edited_on="2017-07-01T10:05:02" last_edited_from="LT_CNDE123"/>
'<GridPoints grid_type="UTC" anomaly_id="SX-001" grid_point="2" pos_x005F_x="5.00" pos_y="9.2000002e-001" dim_z="2.00" notes="SX-001 UT Wall Thickness-1 O'clock" last_edited_by="John.Doe@CoastNDE.com" last_edited_on="2017-07-01T10:05:05.480" last_edited_from="LT_CNDE123"/>
'<GridPoints grid_type="UTC" anomaly_id="SX-001" grid_point="3" pos_x005F_x="5.00" pos_y="1.8300000e+000" dim_z="2.0999999e-001" notes="SX-001 UT Wall Thickness-2 O'clock" last_edited_by="John.Doe@CoastNDE.com" last_edited_on="2017-07-01T10:05:09.200" last_edited_from="LT_CNDE123"/>
'<GridPoints grid_type="UTC" anomaly_id="SX-001" grid_point="4" pos_x005F_x="5.00" pos_y="2.7500000e+000" dim_z="2.1799999e-001" notes="SX-001 UT Wall Thickness-3 O'clock" last_edited_by="John.Doe@CoastNDE.com" last_edited_on="2017-07-01T10:05:13.020" last_edited_from="LT_CNDE123"/>


End Function

Sub ConfirmOrFixRangeHeaders(RNG As Range, sHeader As String)
Dim rngAdjusted As Range

    If RNG(1, 1).Text = sHeader Then Exit Sub
    
    'Range does not inlude headers - extend it up one row
    Set rngAdjusted = ExpandRange(RNG, 0, 1, 0, 0)
    If rngAdjusted(1, 1).Text = sHeader Then
        Debug.Print "Range " & RNG.Name & " Extended Up to Include Header " & sHeader
        Set RNG = rngAdjusted
    Else
        Debug.Print "Range " & RNG.Name & " COULD NOT BE FIXED! No Matching Header: " & sHeader
    End If
    
End Sub

Function ExpandRange(RNG As Variant, iLeft As Long, iUp As Long, iRight As Long, iDown As Long) As Range
Dim ws As Worksheet
Set ws = RNG.Parent
    If RNG.Column - iLeft < 1 Or _
       RNG.row - iUp < 1 Or _
       RNG.Column + iRight > ActiveSheet.Columns.Count Or _
       RNG.row + iDown > ActiveSheet.Rows.Count Then
            MsgBox "Out of range"
            Exit Function
    End If

 Set ExpandRange = ws.Range(RNG.Offset(-1 * iUp, -1 * iLeft).Address & ":" & RNG.Offset(iDown, iRight).Address)
End Function

'2018-08-13 Change to exact match for optional second param
Function iGetColumnFromHeader(RNG As Range, sHeadingLike As String, sOptionalHeadingExact As String) As Integer
Dim iCol As Integer
    iGetColumnFromHeader = 0
    
    For iCol = 1 To RNG.Columns.Count
        If (sHeadingLike > "" And RNG.Cells(1, iCol).Text Like "*" & sHeadingLike & "*") Or (sOptionalHeadingExact > "" And RNG.Cells(1, iCol).Text = sOptionalHeadingExact) Then
            iGetColumnFromHeader = iCol
            Exit Function
        End If
    Next
    Debug.Print "NO MATCH FOUND FOR: " & sHeadingLike & " or " & sOptionalHeadingExact

End Function


Sub Test()
Dim iCnt As Integer
Dim sTest As String

For iCnt = 32 To 255
    sTest = sTest & Chr(iCnt)
Next iCnt


Debug.Print sSafeXML(sTest)

End Sub

'Ensures value passed into sNum is a numaric value and returns it
'2018-08-13 Added replace for quotes and half quotes before isnumeric test
'           Changed sIn to ByRef
Function sNum(ByRef sIn As String) As String
    sIn = Replace(Replace(sIn, Chr(34), ""), "'", "")
    If IsNumeric(sIn) = True Then
        sNum = Val(sIn) & ""
    Else
        sNum = ""
        Debug.Print "Non Numeric Value " & sIn & " Stripped."
    End If
End Function

Function sSafeXML(sValue As String) As String

Dim sOut As String
Dim sHold As String
Dim iCount As Integer

    For iCount = 1 To Len(sValue)
        If Asc(Mid(sValue, iCount, 1)) > 126 Then
            Debug.Print "Extended ASCII " & Asc(Mid(sValue, iCount, 1)) & " striped."
        Else
            sOut = sOut & Mid(sValue, iCount, 1)
        End If
        
    Next iCount
    
    If InStr(1, sOut, "&amp", vbTextCompare) = 0 Then
        sOut = Replace(sOut, "&", "&")
    End If
    sOut = Replace(sOut, "<", "<")
    sOut = Replace(sOut, ">", ">")
    sOut = Replace(sOut, "'", "&apos;")
    sOut = Replace(sOut, Chr(34), """)  '  "
    
    
' [url]https://en.wikipedia.org/wiki/List_of_XML_and_HTML_character_entity_references[/url]
' EXTENDED ASCII CHARECTERS SHOULD NOT BE USED
'    sOut = Replace(sOut, Chr(133), "&[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 33;")
'    sOut = Replace(sOut, Chr(42), "*") ' *


    sSafeXML = sOut
'NOTE: FUTURE WORK: For UTF-8 we should also strip out special/upper ascii characters too!

'REQUIRED REPLACEMENTS - THESE WILL BREAK XML PROCESSING ON IMPORT IF USER ENTERS THEM
'amp    &   & (ampersand)
'lt     <    < (less than)
'gt     >    > (greater than)
'apos   &apos;  ' (apostrophe or single quote)
'quot   "  " (double quote)

End Function





Sub LoadPropertiesList()
    sdProperties.RemoveAll
    sdProperties.CompareMode = vbTextCompare
'make case insensitive
    sdProperties.Add "DEH_ATTACH_Casing_Data_Sheet", "Y"
    sdProperties.Add "DEH_ATTACH_Certifications", "Y"
    sdProperties.Add "DEH_ATTACH_Coating_Chain_Of_Custody", "Y"
    sdProperties.Add "DEH_ATTACH_Coating_Inspection", "Y"
    sdProperties.Add "DEH_ATTACH_Correspondence", "Y"
    sdProperties.Add "DEH_ATTACH_GPS_Corrected_COR", "Y"
    sdProperties.Add "DEH_ATTACH_GPS_Uncorrected_SSF", "Y"
    sdProperties.Add "DEH_ATTACH_Laser_Scan", "Y"
    sdProperties.Add "DEH_ATTACH_NDE_Workbook", "Y"
    sdProperties.Add "DEH_ATTACH_Soil_Chain_Of_Custody", "Y"
    sdProperties.Add "DEH_ATTACH_Wax_Fill_Caclucation", "Y"
    sdProperties.Add "DEH_CONTACT_DE_Manager", "Y"
    sdProperties.Add "DEH_CONTACT_DE_Tech", "Y"
    sdProperties.Add "DEH_CONTACT_IM_Engineer", "Y"
    sdProperties.Add "DEH_CONTACT_PMO_Lead", "Y"
    sdProperties.Add "DEH_EXCAV_Actual_Length", "Y"
    sdProperties.Add "DEH_EXCAV_Design_Factor", "Y"
    sdProperties.Add "DEH_EXCAV_Excavation_Priority", "Y"
    sdProperties.Add "DEH_EXCAV_Excavation_Reason", "Y"
    sdProperties.Add "DEH_EXCAV_MAOP", "Y"
    sdProperties.Add "DEH_EXCAV_Nominal_Pipe_Diameter", "Y"
    sdProperties.Add "DEH_EXCAV_Nominal_Wall_Thickness", "Y"
    sdProperties.Add "DEH_EXCAV_Planned_Length", "Y"
    sdProperties.Add "DEH_EXCAV_PS_Comments", "Y"
    sdProperties.Add "DEH_EXCAV_PS_Off", "Y"
    sdProperties.Add "DEH_EXCAV_PS_On", "Y"
    sdProperties.Add "DEH_EXCAV_SMYS", "Y"
    sdProperties.Add "DEH_GPS_Centerline_Latitude", "Y"
    sdProperties.Add "DEH_GPS_Centerline_Longitude", "Y"
    sdProperties.Add "DEH_GPS_Corrected_Easting", "Y"
    sdProperties.Add "DEH_GPS_Corrected_Northing", "Y"
    sdProperties.Add "DEH_GPS_DS_Edge_Latitude", "Y"
    sdProperties.Add "DEH_GPS_DS_Edge_Longitude", "Y"
    sdProperties.Add "DEH_GPS_File_Name", "Y"
    sdProperties.Add "DEH_GPS_GIS_Easting", "Y"
    sdProperties.Add "DEH_GPS_GIS_Lattitude", "Y"
    sdProperties.Add "DEH_GPS_GIS_Longitude", "Y"
    sdProperties.Add "DEH_GPS_GIS_Northing", "Y"
    sdProperties.Add "DEH_GPS_Uncorrected_Easting", "Y"
    sdProperties.Add "DEH_GPS_Uncorrected_Northing", "Y"
    sdProperties.Add "DEH_GPS_Zero_Ref_Latitude", "Y"
    sdProperties.Add "DEH_GPS_Zero_Ref_Longitude", "Y"
    sdProperties.Add "DEH_HEADER_Approved_By", "Y"
    sdProperties.Add "DEH_HEADER_Delay_Reason", "Y"
    sdProperties.Add "DEH_HEADER_Dig_ID", "Y"
    sdProperties.Add "DEH_HEADER_Distance_From_Girth_Weld", "Y"
    sdProperties.Add "DEH_HEADER_Examination_Date", "Y"
    sdProperties.Add "DEH_HEADER_ILI_Log_Distance", "Y"
    sdProperties.Add "DEH_HEADER_IMA_Number", "Y"
    sdProperties.Add "DEH_HEADER_Installation_Year", "Y"
    sdProperties.Add "DEH_HEADER_Mile_Point", "Y"
    sdProperties.Add "DEH_HEADER_N_Segment", "Y"
    sdProperties.Add "DEH_HEADER_Order_Number", "Y"
    sdProperties.Add "DEH_HEADER_Performed_By", "Y"
    sdProperties.Add "DEH_HEADER_PGE_Project_Manager", "Y"
    sdProperties.Add "DEH_HEADER_Reference_Girth_Weld", "Y"
    sdProperties.Add "DEH_HEADER_Region_Number", "Y"
    sdProperties.Add "DEH_HEADER_RMP_11_Ref_Section", "Y"
    sdProperties.Add "DEH_HEADER_Route_Number", "Y"
    sdProperties.Add "DEH_HEADER_SAP_Notification_Number", "Y"
    sdProperties.Add "DEH_HEADER_Stationing", "Y"
    sdProperties.Add "DEH_HEADER_Subregion_Number_ICDA", "Y"
    sdProperties.Add "DEH_MAG_Acceptance_Criteria", "Y"
    sdProperties.Add "DEH_MAG_Assistant_Level", "Y"
    sdProperties.Add "DEH_MAG_Assistant_Name", "Y"
    sdProperties.Add "DEH_MAG_Comments", "Y"
    sdProperties.Add "DEH_MAG_Equipment_Serial_No", "Y"
    sdProperties.Add "DEH_MAG_Examination_Date", "Y"
    sdProperties.Add "DEH_MAG_Medium", "Y"
    sdProperties.Add "DEH_MAG_Quality_Control_Batches", "Y"
    sdProperties.Add "DEH_MAG_Reference_GPS_Easting", "Y"
    sdProperties.Add "DEH_MAG_Reference_GPS_Northing", "Y"
    sdProperties.Add "DEH_MAG_Results_Accepted", "Y"
    sdProperties.Add "DEH_MAG_Results_Available", "Y"
    sdProperties.Add "DEH_MAG_Surface_Condition", "Y"
    sdProperties.Add "DEH_MAG_Technician_Level", "Y"
    sdProperties.Add "DEH_MAG_Technician_Name", "Y"
    sdProperties.Add "DEH_MAG_Technique", "Y"
    sdProperties.Add "DEH_MAG_Test_Equipment", "Y"
    sdProperties.Add "DEH_POST_Corrosion_Damage", "Y"
    sdProperties.Add "DEH_POST_Girth_Weld_Coord_Easting", "Y"
    sdProperties.Add "DEH_POST_Girth_Weld_Coord_Northing", "Y"
    sdProperties.Add "DEH_POST_Girth_Weld_Elevation", "Y"
    sdProperties.Add "DEH_POST_Linear_Indications", "Y"
    sdProperties.Add "DEH_POST_Long_Seam_Characterization", "Y"
    sdProperties.Add "DEH_POST_Mechanical_Damage", "Y"
    sdProperties.Add "DEH_POST_Other_Damage_Notes", "Y"
    sdProperties.Add "DEH_POST_Pipe_Diameter", "Y"
    sdProperties.Add "DEH_POST_Pipe_Temperature", "Y"
    sdProperties.Add "DEH_POST_Seam_2_Position", "Y"
    sdProperties.Add "DEH_POST_Seam_3_Position", "Y"
    sdProperties.Add "DEH_POST_Seam_Clock_Position", "Y"
    sdProperties.Add "DEH_POST_Weld_Seam_2_Type", "Y"
    sdProperties.Add "DEH_POST_Weld_Seam_3_Type", "Y"
    sdProperties.Add "DEH_POST_Weld_Seam_Type", "Y"
    sdProperties.Add "DEH_POST_Wet_Fluor_Mag_Comments", "Y"
    sdProperties.Add "DEH_POST_Wet_Fluor_Performed", "Y"
    sdProperties.Add "DEH_PRE_Coating_Conditions", "Y"
    sdProperties.Add "DEH_PRE_Coating_Conditions_Comments", "Y"
    sdProperties.Add "DEH_PRE_Coating_Sample_Location", "Y"
    sdProperties.Add "DEH_PRE_Coating_Sample_Taken", "Y"
    sdProperties.Add "DEH_PRE_Corrosion_Comments", "Y"
    sdProperties.Add "DEH_PRE_Corrosion_Product_Present", "Y"
    sdProperties.Add "DEH_PRE_Corrosion_Sample", "Y"
    sdProperties.Add "DEH_PRE_Ground_Water_Collected", "Y"
    sdProperties.Add "DEH_PRE_Ground_Water_PH", "Y"
    sdProperties.Add "DEH_PRE_Ground_Water_Present", "Y"
    sdProperties.Add "DEH_PRE_Liquid_PH", "Y"
    sdProperties.Add "DEH_PRE_Liquid_Underneath_Coating", "Y"
    sdProperties.Add "DEH_PRE_Photos_Taken", "Y"
    sdProperties.Add "DEH_PRE_Soil_PH_Downstream", "Y"
    sdProperties.Add "DEH_PRE_Soil_PH_Upstream", "Y"
    sdProperties.Add "DEH_PRE_Soil_Sample_Comment", "Y"
    sdProperties.Add "DEH_PRE_Soil_Sample_Location", "Y"
    sdProperties.Add "DEH_PRE_Zero_Reference_Point", "Y"
    sdProperties.Add "DEH_QAQC_Mapping_Action", "Y"
    sdProperties.Add "DEH_QAQC_QA_Selection_Code", "Y"
    sdProperties.Add "DEH_QAQC_QA_Selection_Date", "Y"
    sdProperties.Add "DEH_QAQC_QA_Status", "Y"
    sdProperties.Add "DEH_QAQC_Reconcilled_with_SAP", "Y"
    sdProperties.Add "DEH_QAQC_Selected_For_QA", "Y"
    sdProperties.Add "DEH_RECOAT_Anchor_Profile_Measure", "Y"
    sdProperties.Add "DEH_RECOAT_Client_Approved_By", "Y"
    sdProperties.Add "DEH_RECOAT_Coating_Thickness_03", "Y"
    sdProperties.Add "DEH_RECOAT_Coating_Thickness_06", "Y"
    sdProperties.Add "DEH_RECOAT_Coating_Thickness_09", "Y"
    sdProperties.Add "DEH_RECOAT_Coating_Thickness_12", "Y"
    sdProperties.Add "DEH_RECOAT_Comments", "Y"
    sdProperties.Add "DEH_RECOAT_Dew_Point", "Y"
    sdProperties.Add "DEH_RECOAT_Envir_Cond_Air_Temp", "Y"
    sdProperties.Add "DEH_RECOAT_Envir_Cond_Pipe_Temp", "Y"
    sdProperties.Add "DEH_RECOAT_Holiday_Device_Used", "Y"
    sdProperties.Add "DEH_RECOAT_Holiday_Test_Voltage", "Y"
    sdProperties.Add "DEH_RECOAT_Holiday_Tested", "Y"
    sdProperties.Add "DEH_RECOAT_Mears_Approved_By", "Y"
    sdProperties.Add "DEH_RECOAT_Pipe_Recoated_With", "Y"
    sdProperties.Add "DEH_RECOAT_Relative_Humidity", "Y"
    sdProperties.Add "DEH_RECOAT_Repair_Coating_Hardness", "Y"
    sdProperties.Add "DEH_RECOAT_Sandblast_Media", "Y"
    sdProperties.Add "DEH_RECOAT_Time", "Y"
    sdProperties.Add "DEH_REPAIR_Comments", "Y"
    sdProperties.Add "DEH_REPAIR_Damage_Repaired", "Y"
    sdProperties.Add "DEH_REPAIR_Made", "Y"
    sdProperties.Add "DEH_REPAIR_Number_Made", "Y"
    sdProperties.Add "DEH_REPAIR_Repair_Type", "Y"
    sdProperties.Add "DEH_RES_4pin_Multiplier", "Y"
    sdProperties.Add "DEH_RES_4pin_Ohms", "Y"
    sdProperties.Add "DEH_RES_4pin_Resitivity", "Y"
    sdProperties.Add "DEH_RES_4pin_Spacing", "Y"
    sdProperties.Add "DEH_RES_Comments", "Y"
    sdProperties.Add "DEH_RES_Soil_Box_Multiplier", "Y"
    sdProperties.Add "DEH_RES_Soil_Box_Ohms", "Y"
    sdProperties.Add "DEH_RES_Soil_Box_Resistivity", "Y"
    sdProperties.Add "DEH_RESTORE_Backfill_Comments", "Y"
    sdProperties.Add "DEH_RESTORE_Backfill_Material", "Y"
    sdProperties.Add "DEH_RESTORE_Coating_Protection_Type", "Y"
    sdProperties.Add "DEH_RESTORE_Coupon_Test_Installed", "Y"
    sdProperties.Add "DEH_RESTORE_Date_Coupon_Installed", "Y"
    sdProperties.Add "DEH_RESTORE_Date_ETS_Installed", "Y"
    sdProperties.Add "DEH_RESTORE_ETS_Installed", "Y"
    sdProperties.Add "DEH_RESTORE_PTS_Read_After", "Y"
    sdProperties.Add "DEH_RESTORE_PTS_Read_Comments", "Y"
    sdProperties.Add "DEH_RESTORE_Test_Station_Comments", "Y"
    sdProperties.Add "DEH_RESTORE_Test_Station_Config", "Y"
    sdProperties.Add "DEH_SITE_Additional_Coatings_Found", "Y"
    sdProperties.Add "DEH_SITE_Aerial_Diagram", "Y"
    sdProperties.Add "DEH_SITE_As_Found_Coating_At_12_DS", "Y"
    sdProperties.Add "DEH_SITE_As_Found_Coating_At_12_US", "Y"
    sdProperties.Add "DEH_SITE_As_Found_Coating_At_3_DS", "Y"
    sdProperties.Add "DEH_SITE_As_Found_Coating_At_3_US", "Y"
    sdProperties.Add "DEH_SITE_As_Found_Coating_At_6_DS", "Y"
    sdProperties.Add "DEH_SITE_As_Found_Coating_At_6_US", "Y"
    sdProperties.Add "DEH_SITE_As_Found_Coating_At_9_DS", "Y"
    sdProperties.Add "DEH_SITE_As_Found_Coating_At_9_US", "Y"
    sdProperties.Add "DEH_SITE_Attached_Test_Wires", "Y"
    sdProperties.Add "DEH_SITE_Backfill_As_Found", "Y"
    sdProperties.Add "DEH_SITE_Backfill_Comments", "Y"
    sdProperties.Add "DEH_SITE_Blasted_Surface_At_12_DS", "Y"
    sdProperties.Add "DEH_SITE_Blasted_Surface_At_12_US", "Y"
    sdProperties.Add "DEH_SITE_Blasted_Surface_At_3_DS", "Y"
    sdProperties.Add "DEH_SITE_Blasted_Surface_At_3_US", "Y"
    sdProperties.Add "DEH_SITE_Blasted_Surface_At_6_DS", "Y"
    sdProperties.Add "DEH_SITE_Blasted_Surface_At_6_US", "Y"
    sdProperties.Add "DEH_SITE_Blasted_Surface_At_9_DS", "Y"
    sdProperties.Add "DEH_SITE_Blasted_Surface_At_9_US", "Y"
    sdProperties.Add "DEH_SITE_Casing_Diagram", "Y"
    sdProperties.Add "DEH_SITE_Coating_Layers", "Y"
    sdProperties.Add "DEH_SITE_Coating_Protection", "Y"
    sdProperties.Add "DEH_SITE_Coating_Thickness", "Y"
    sdProperties.Add "DEH_SITE_Coating_Type", "Y"
    sdProperties.Add "DEH_SITE_Coating_Type_Comments", "Y"
    sdProperties.Add "DEH_SITE_Depth_Of_Cover", "Y"
    sdProperties.Add "DEH_SITE_Encroachment_Comments", "Y"
    sdProperties.Add "DEH_SITE_Evidence_Of_Encroachment", "Y"
    sdProperties.Add "DEH_SITE_Excavation_Diagram", "Y"
    sdProperties.Add "DEH_SITE_Native_Soil_Comments", "Y"
    sdProperties.Add "DEH_SITE_Native_Soil_Condition", "Y"
    sdProperties.Add "DEH_SITE_OneCall_1", "Y"
    sdProperties.Add "DEH_SITE_OneCall_2", "Y"
    sdProperties.Add "DEH_SITE_Post_East", "Y"
    sdProperties.Add "DEH_SITE_Post_North", "Y"
    sdProperties.Add "DEH_SITE_Post_South", "Y"
    sdProperties.Add "DEH_SITE_Post_Test_Station", "Y"
    sdProperties.Add "DEH_SITE_Post_West", "Y"
    sdProperties.Add "DEH_SITE_Pre_Excavation_East", "Y"
    sdProperties.Add "DEH_SITE_Pre_Excavation_North", "Y"
    sdProperties.Add "DEH_SITE_Pre_Excavation_South", "Y"
    sdProperties.Add "DEH_SITE_Pre_Excavation_West", "Y"
    sdProperties.Add "DEH_SITE_Primary_Soil_Type", "Y"
    sdProperties.Add "DEH_SITE_Recoat_At_12", "Y"
    sdProperties.Add "DEH_SITE_Recoat_At_3", "Y"
    sdProperties.Add "DEH_SITE_Recoat_At_6", "Y"
    sdProperties.Add "DEH_SITE_Recoat_At_9", "Y"
    sdProperties.Add "DEH_SITE_Recoat_Ds_Transition", "Y"
    sdProperties.Add "DEH_SITE_Recoat_Us_Transition", "Y"
    sdProperties.Add "DEH_SITE_Rock_Shield", "Y"
    sdProperties.Add "DEH_VOLT_Holiday_Comments", "Y"
    sdProperties.Add "DEH_VOLT_Holiday_Device", "Y"
    sdProperties.Add "DEH_VOLT_Holiday_Testing", "Y"
    sdProperties.Add "DEH_VOLT_Holiday_Voltage", "Y"
    sdProperties.Add "DEH_VOLT_Pipe_To_Soil_Comments", "Y"
    sdProperties.Add "DEH_VOLT_Pipe_To_Soil_DS", "Y"
    sdProperties.Add "DEH_VOLT_Pipe_To_Soil_US", "Y"
    sdProperties.Add "DEH_WALL_Ut_Thickness_01", "Y"
    sdProperties.Add "DEH_WALL_Ut_Thickness_02", "Y"
    sdProperties.Add "DEH_WALL_Ut_Thickness_03", "Y"
    sdProperties.Add "DEH_WALL_Ut_Thickness_04", "Y"
    sdProperties.Add "DEH_WALL_Ut_Thickness_05", "Y"
    sdProperties.Add "DEH_WALL_Ut_Thickness_06", "Y"
    sdProperties.Add "DEH_WALL_Ut_Thickness_07", "Y"
    sdProperties.Add "DEH_WALL_Ut_Thickness_08", "Y"
    sdProperties.Add "DEH_WALL_Ut_Thickness_09", "Y"
    sdProperties.Add "DEH_WALL_Ut_Thickness_10", "Y"
    sdProperties.Add "DEH_WALL_Ut_Thickness_11", "Y"
    sdProperties.Add "DEH_WALL_Ut_Thickness_12", "Y"

End Sub

 

Function nGetSafeNumber(sValue As String, nFailValue) As Single

    If Val(sValue) = 0 And sValue <> "0" Then
        nGetSafeNumber = nFailValue
        Debug.Print "INVALID NUMERIC VALUE FOR: " & sValue
    Else
        nGetSafeNumber = Val(sValue)
    End If
        

End Function


Function sGetSafeValue(RNG As Range, sType) As String
Dim sValue As String
Dim sText As String
Dim sReturn As String

    sValue = RNG.Value
    sText = RNG.Text
    
    Debug.Print "VALUE: " & sValue & " TEXT: " & sText
    
    Select Case UCase(Mid(sType, 1, 1))
    Case "N"
            sReturn = Val(sValue)
        Case "D"
            sReturn = Format(sValue, "YYYY-MM-DD")
        Case "S", "C", "T"
            sReturn = sValue
        Case Else
            MsgBox "Invalid Type specified for sGetSafeValue: " & sType & vbCrLf & "Choose Number, Date or String"
    
    End Select
    
    sGetSafeValue = sReturn
        

End Function


Public Function bSheetExists(objWorkbook As Workbook, sName As String) As Boolean
    'Moved from ProcessFile for portability.
    Dim sSheet As Worksheet

    On Error GoTo bSheetExists_NO
    Set sSheet = objWorkbook.Sheets(sName)
    bSheetExists = True
        
    Exit Function
    
bSheetExists_NO:
    bSheetExists = False
     
 End Function
 
Public Function bNameExists(objWorkbook As Workbook, sWorksheet As String, sName As String) As Boolean
    'Moved from ProcessFile for portability.
    Dim RNG As Range
'If gbInitXML = False Then InitXML
    On Error GoTo bNameExists_NO
    Set RNG = objWorkbook.Worksheets(sWorksheet).Range(sName)
    
    bNameExists = True
        
    Exit Function
    
bNameExists_NO:
    bNameExists = False

 End Function


Public Sub InitXML()

Dim iCol As Integer
Dim sHeader As String
Dim sValue As String
Dim WKB As Workbook
   
    
    If gSectionUnitsMultiplier = 0 Then
        gSectionUnitsMultiplier = 1
    End If
    
    
    If ActiveWorkbook.Name = "C2CMaster.xlsm" Or ActiveWorkbook.Name = "Process.xlsx" Then 'Batch process option
    
        For Each WKB In Workbooks
            If WKB.Name = "C2CMaster.xlsm" Then
                Set wkbMaster = WKB
            End If
        Next
        Set rngMaster = wkbMaster.Worksheets("Status").Range("MASTER_STATUS") 'Entire Table
        Set rngCurrent = wkbMaster.Worksheets("Status").Range("CURRENT_FILE")
        
        sdProcess.RemoveAll
        sdProcess.CompareMode = TextCompare
        sdHeaders.RemoveAll
        sdHeaders.CompareMode = TextCompare
        
        
        For iCol = 1 To rngMaster.Columns.Count
            sHeader = rngMaster(1, iCol).Text
            sValue = rngCurrent(1, iCol).Text
            sdHeaders.Add sHeader, iCol
            sdProcess.Add sHeader, sValue
            'Debug.Print iCol & " " & sHeader & "=" & sValue
        Next iCol
        

        On Error Resume Next 'allow for already open PROCESS.XLSX to be used
        If wkbInProcess Is Nothing Then
            Set wkbInProcess = Workbooks("Process.xlsx")
        End If
        If wkbInProcess.Name <> "Process.xlsx" Then
            Set wkbInProcess = Workbooks.Open(WORKINGPATH & "Process.xlsx")
        End If
    
    Else 'Standard Single file Process
    
        Set wkbInProcess = ActiveWorkbook
    
    
    End If
    
    On Error GoTo 0
    Debug.Print wkbInProcess.Name & " IS OPEN"
    gbInitXML = True
        
    
    
End Sub


Sub CreateNamedRange(sName As String, sWorksheet As String, Optional sAddress As String = "", Optional bForceRange As Boolean = False) 'Copied for XMLGenerator local testing 2019_10_17

Dim RNG As Range
Dim sTmp  As String
'If gbInitXML = False Then InitXML

    If bNameExists(wkbInProcess, sWorksheet, sName) = False Or bForceRange = True Then
    
        wkbInProcess.Worksheets(sWorksheet).Activate

        If sAddress = "" Then
            'MsgBox "Select Range for: " & sName & " then continue." & vbCrLf & vbCrLf & "Use <CTRL> <BREAK> to pause", vbOKOnly, "Select Range"
            Set RNG = Application.InputBox("Select the range for " & sName & ".", "Select Range", Type:=8)
            
            'Set Application.Names(sName).RefersToRange = RNG
            wkbInProcess.Names.Add Name:=sName, RefersTo:=RNG
            'Application.Selection.Name = sName 'ADD BREAK POINT HERE
        Else
            If Mid(sAddress, 1, 1) = "R" Then
               'Context must be the Active Worksheet for this to work
               sTmp = wkbInProcess.Names.Add(Name:=sName, RefersToR1C1:="=" & Replace(sAddress, "!", ""))
                'Specifying the Worksheet is the preferred way to do it, but WorkSheet names with spaces will fail!
               'sTmp = wkbInProcess.Names.Add(Name:=sName, RefersToR1C1:="=" & sWorksheet & "!" & Replace(sAddress, "!", ""))
                'wkbInProcess.Names.Add Name:=sName, RefersTo:="=Indication Table!$C$7:$DT$257"
            Else
               'Context must be the Active Worksheet for this to work
                sTmp = wkbInProcess.Names.Add(Name:=sName, RefersTo:="=" & Replace(sAddress, "!", ""))
                'Specifying the Worksheet is the preferred way to do it, but WorkSheet names with spaces will fail!
                'sTmp = wkbInProcess.Names.Add(Name:=sName, RefersTo:="=" & sWorksheet & "!" & Replace(sAddress, "!", ""))
                'wkbInProcess.Names.Add Name:=sName, RefersTo:="=Indication Table!$C$7:$DT$257"
            End If
            Debug.Print "CREATED Named Range: " & sName & " AT " & sTmp
        End If
        
    End If

    'wkbInProcess.Names(sName).Select

End Sub


Sub CreateRanges()

    If gbInitXML = False Then InitXML
        
'    If bNameExists(wkbInProcess, "TCAT_Codes", "TCAT_Indication_Legend") = False Then CreateNamedRange "TCAT_Indication_Legend", "TCAT_Codes", "R2C1:R22C4"
    

'    If bNameExists(wkbInProcess, "RAW", "MP") = False Then CreateNamedRange "MP", "RAW", ""
    
'    If bNameExists(wkbInProcess, "RAW", "Station_number") = False Then CreateNamedRange "Station_number", "RAW", ""
    
'    If bNameExists(wkbInProcess, "RAW", "LINE_NO") = False Then CreateNamedRange "LINE_NO", "RAW", ""
    
'    If bNameExists(wkbInProcess, "RAW", "CLIENT_PM") = False Then CreateNamedRange "CLIENT_PM", "RAW", ""
    
'    If bNameExists(wkbInProcess, "SS", "SITE_SUMMARY") = False Then CreateNamedRange "SITE_SUMMARY", "SS", "R20C1:R76C117"
    
'    If bNameExists(wkbInProcess, "Sections", "Sections_UTC_Data") = False Then CreateNamedRange "Sections_UTC_Data", "Sections", "!$B$8:$AA$28"
    
'    If bNameExists(wkbInProcess, "Sections", "UTC_Sections") = False Then CreateNamedRange "UTC_Sections", "Sections", "!$A$15:$AA$28"
    
'    If bNameExists(wkbInProcess, "Indication Table", "Indication_Report_Data") = True Then
'        wkbInProcess.Names.Item("Indication_Report_Data").Delete
'    End If
'    CreateNamedRange "Indication_Report_Data", "Indication Table", "$C$7:$DT$257", True
'    wkbInProcess.Worksheets("Indication Table").Activate
    
    CreateNamedRange "Indication_Report_Data", "Indication Table", "R7C3:R257C121", True     '2019_10_03 Added due to high error rate when importing indications.
    Names("Indication_Report_Data").Visible = True
    
    CreateNamedRange "PROPERTIES", "New XML", "R2C1:R5C200", True     '2019_10_04 Added to capture resorted property list.
    Names("Indication_Report_Data").Visible = True

    wkbInProcess.Worksheets("Master").Activate

End Sub


Sub HideUnhideWorkpages(bOperation As Boolean)

If gbInitXML = False Then InitXML

' UnhideWorkpages Macro

'    wkbInProcess.Sheets("XML").Visible = True
    wkbInProcess.Sheets("New XML").Visible = bOperation '2019-09-30 Changed to "New XML" to handle 180 series errors
    If bSheetExists(wkbInProcess, "Master") = True Then
        wkbInProcess.Sheets("Master").Visible = bOperation
    Else
        wkbInProcess.Sheets("RAW").Visible = bOperation
    End If
'    wkbInProcess.Sheets("RAW").Visible = True
    If bSheetExists(wkbInProcess, "TCAT_Codes") = True Then
        wkbInProcess.Sheets("TCAT_Codes").Visible = bOperation
    End If
    wkbInProcess.Sheets("Sections").Visible = bOperation

End Sub


Function sCheckMills(sValue As String) As String
'

Dim sReturn As String

    
    
    If Val(sValue) >= 1 Then
        sReturn = CStr(Val(sValue) / 1000)
        
    Else
        sReturn = sValue
        
    End If

    sCheckMills = sReturn
    
End Function

Jaafar Tribak · Nov 7, 2019

dcoker said:
I have new code that is needed for older files that did not originally have this reference enabled. :/
Roughly 50 files
Trying to save some time for when I go back and fix the old files using the updated code...

If you just want to save time why don't you place the line in each of the 50 files open event :

Code:

Private Sub Workbook_Open()
    Me.VBProject.References.AddFromGUID "{420B2830-E718-11CF-893D-00A0C9054228}", 1, 0
End Sub

Or better still, if you have a personal.xlsb workbook or a workbook in \Excel\XLSTART folder and place the following code in its ThisWorkbook module then the Scripting library should be loaded for each and every file automatically :

Code:

Option Explicit

Private WithEvents xlapp As Application

Private Sub Workbook_Open()
    Set xlapp = Application
End Sub

Private Sub xlapp_WorkbookOpen(ByVal Wb As Workbook)
    Wb.VBProject.References.AddFromGUID "{420B2830-E718-11CF-893D-00A0C9054228}", 1, 0
End Sub

Enable Microsoft Scripting Runtime with vba within a Public Sub with Public Declarations

dcoker

New Member

Excel Facts

RoryA

MrExcel MVP, Moderator

dcoker

New Member

RoryA

MrExcel MVP, Moderator

dcoker

New Member

Jaafar Tribak

Well-known Member

Similar threads

Forum statistics

Share this page

Enable Microsoft Scripting Runtime with vba within a Public Sub with Public Declarations

dcoker

New Member

Excel Facts

RoryA

MrExcel MVP, Moderator

dcoker

New Member

RoryA

MrExcel MVP, Moderator

dcoker

New Member

Jaafar Tribak

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock