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, "&", vbTextCompare) = 0 Then
sOut = Replace(sOut, "&", "&")
End If
sOut = Replace(sOut, "<", "<")
sOut = Replace(sOut, ">", ">")
sOut = Replace(sOut, "'", "'")
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 ' ' (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
