VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} vlnWestROConvert 
   Caption         =   "Convert Westinghouse Field to PROMS RO"
   ClientHeight    =   4065
   ClientLeft      =   45
   ClientTop       =   345
   ClientWidth     =   7365
   OleObjectBlob   =   "vlnWestROConvert.frx":0000
   ShowModal       =   0   'False
   StartUpPosition =   1  'CenterOwner
End
Attribute VB_Name = "vlnWestROConvert"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim continueProcessing As Boolean
Dim dicTypeTranslate As Scripting.Dictionary
Dim dicDBTranslate As Scripting.Dictionary
Dim dicInvalidRO As Scripting.Dictionary
Dim dicValidRO As Scripting.Dictionary
Dim validAccPageID As String
Private Function GetNextField(fld As Field) As Field
    If fld.Next Is Nothing Then
        Set GetNextField = fld.Next
    Else
        Dim fldNext As Field
        Set fldNext = fld.Next
        If (Mid(fldNext.Code.Text, 1, 8) = " QUOTE <") Then
            Set GetNextField = fldNext
        Else
            Set GetNextField = GetNextField(fldNext)
        End If
    End If
End Function
Private Function GetPreviousField(fld As Field) As Field
    If fld.Previous Is Nothing Then
        Set GetPreviousField = fld.Previous
    Else
        Dim fldPrev As Field
        Set fldPrev = fld.Previous
        If (Mid(fldPrev.Code.Text, 1, 8) = " QUOTE <") Then
            Set GetPreviousField = fldPrev
        Else
            Set GetPreviousField = GetPreviousField(fldPrev)
        End If
    End If
End Function
Private Function GetNextText(fld As Field) As String
    Dim fldNext As Field
    Set fldNext = GetNextField(fld)
    If fldNext Is Nothing Then
        GetNextText = ""
    Else
        GetNextText = GetRO(fldNext.Code.Text)
    End If
End Function
Private Function GetPreviousText(fld As Field) As String
    Dim fldPrev As Field
    Set fldPrev = GetPreviousField(fld)
    If fldPrev Is Nothing Then
        GetPreviousText = ""
    Else
        GetPreviousText = GetRO(fldPrev.Code.Text)
    End If
End Function
Sub ProcessField(fld As Field, ro As String, txt As String, roPrev As String, roNext As String)
    fld.Select
    ActiveWindow.ScrollIntoView Selection.Range, True
    Dim clipboard As MSForms.DataObject
    Set clipboard = New MSForms.DataObject
    Dim roText As String
    If Left(ro, 4) = "<ARP" Then
        roText = GetARPRO(ro, roPrev, roNext)
    Else
        roText = ro
    End If
    tbRO.Text = roText
    tbPROMSRO.Text = PromsRO(roText, fld)
    tbText.Text = txt
    clipboard.SetText tbRO.Text
    clipboard.PutInClipboard
End Sub
Private Function ReadableText(txt As String)
    txt = Replace(txt, Chr(7), "")
    txt = Replace(txt, Chr(12), "")
    txt = Replace(txt, Chr(13), "")
    txt = Replace(txt, Chr(30), "-")
    ReadableText = ""
    Dim i As Integer
    For i = 1 To Len(txt)
        If Asc(Mid(txt, i, 1)) < 32 Then
            ReadableText = ReadableText + "[" + CStr(Asc(Mid(txt, i, 1))) + "]"
        Else
            ReadableText = ReadableText + Mid(txt, i, 1)
        End If
    Next
End Function
Private Function PromsRO(wro As String, fld As Field) As String
    PromsRO = RoDBConvert(Mid(wro, 1, 4))
    Dim nextSpace As Integer
    nextSpace = InStr(6, wro, " ")
    If nextSpace = 0 Then
        nextSpace = InStr(6, wro, "\")
     End If
    PromsRO = PromsRO + Mid(wro, 6, nextSpace - 6)
    Dim accPageID As String
    accPageID = Design() + "-" + Mid(PromsRO, 2)
    Dim firstSlash As Integer
    firstSlash = InStr(wro, "\")
    Dim roType As String
    roType = UCase(Mid(wro, firstSlash + 1, 1))
    Dim typeSub As String
    typeSub = Mid(wro, 2, 3) + roType
    If Not ValidRO(accPageID) Then ' Not a valid RO
        tbPROMSRO.BackColor = RGB(255, 255, 0)
        btnConvert.Caption = "Convert Missing RO to Text"
        PromsRO = ReadableText(fld.Result)
    ElseIf typeSub = "MELC" Then
        tbPROMSRO.BackColor = RGB(128, 255, 128)
        btnConvert.Caption = "Convert Common Description to Text"
        PromsRO = ReadableText(fld.Result)
    Else
        If accPageID <> validAccPageID Then
            PromsRO = Replace(PromsRO, Mid(accPageID, 5), Mid(validAccPageID, 5))
        End If
        tbPROMSRO.BackColor = RGB(255, 255, 255)
        btnConvert.Caption = "Convert to PROMS RO"
        PromsRO = PromsRO + RoTypeConvert(typeSub) + ">"
    End If
End Function
Private Function Design() As String
    Design = tbDesign.Text
    'On Error Resume Next
    'Design = Mid(ActiveDocument.CustomDocumentProperties("Doc_Number").Value, 1, 3)
End Function
Private Function InvalidRO(accPageID As String)
    If dicInvalidRO Is Nothing Then
        BuildDicInvalidRO
    End If
    InvalidRO = dicInvalidRO.Exists(accPageID)
End Function
Private Sub BuildDicInvalidRO()
    Set dicInvalidRO = New Scripting.Dictionary
    AddInvalids "APP-ARP-", "Select * FROM APPARPFieldsNotInROs_qry"
    AddInvalids "APP-MEL-", "Select * FROM APPMELFieldsNotInROs_qry"
    AddInvalids "APP-STP-", "Select * FROM APPSTPFieldsNotInROs_qry"
    AddInvalids "CPP-ARP-", "Select * FROM CPPARPFieldsNotInROs_qry"
    AddInvalids "CPP-MEL-", "Select * FROM CPPMELFieldsNotInROs_qry"
    AddInvalids "CPP-STP-", "Select * FROM CPPSTPFieldsNotInROs_qry"
End Sub
Private Sub AddInvalids(prefix As String, query As String)
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
     'Establish connection
    Set dbs = OpenDatabase("c:\vewest\westfields.mdb")
     'Fill recordset
    Set rst = dbs.OpenRecordset(query)
     'Fill combo by looping through the recordset
    Do While Not rst.EOF
        Dim key As String
        key = prefix + rst.Fields(0)
        dicInvalidRO.Add key, 0
        rst.MoveNext
    Loop
     'Clean up
    Set rst = Nothing
    Set dbs = Nothing
End Sub
Private Function ValidRO(accPageID As String) As Boolean
    If dicValidRO Is Nothing Then
        BuildDicValidRO
    End If
    If IsValidRO(accPageID) Then GoTo ValidRODone
    If IsValidRO(accPageID + "-HI1") Then GoTo ValidRODone
    If IsValidRO(accPageID + "-LO1") Then GoTo ValidRODone
    If IsValidRO(accPageID + "-HI2") Then GoTo ValidRODone
    If IsValidRO(accPageID + "-LO2") Then GoTo ValidRODone
    If IsValidRO(accPageID + "-HI3") Then GoTo ValidRODone
    If IsValidRO(accPageID + "-LO3") Then GoTo ValidRODone
    If IsValidRO(accPageID + "-HI4") Then GoTo ValidRODone
    If IsValidRO(accPageID + "-LO4") Then GoTo ValidRODone
    ValidRO = False
    Exit Function
ValidRODone:
    ValidRO = True
End Function
Private Function IsValidRO(accPageID As String) As Boolean
    IsValidRO = dicValidRO.Exists(accPageID)
    If IsValidRO Then
        validAccPageID = accPageID
    Else
        validAccPageID = ""
    End If
End Function
Private Sub BuildDicValidRO()
    Set dicValidRO = New Scripting.Dictionary
    AddValids "APP-ARP-", "Select Alarm FROM AlarmAPP"
    AddValids "APP-MEL-", "Select FullName From MELAPP"
    AddValids "APP-STP-", "Select Name FROM SetpointData"
    AddValids "CPP-ARP-", "Select Alarm from AlarmSMG"
    AddValids "CPP-MEL-", "Select FullName From MELCPP"
    AddValids "CPP-STP-", "Select Name From SetpointDataCPP"
End Sub
Private Sub AddValids(prefix As String, query As String)
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
     'Establish connection
    Set dbs = OpenDatabase("c:\vewest\westfields.mdb")
     'Fill recordset
    Set rst = dbs.OpenRecordset(query)
     'Fill combo by looping through the recordset
    Do While Not rst.EOF
        Dim key As String
        key = prefix + rst.Fields(0)
        dicValidRO.Add key, 0
        rst.MoveNext
    Loop
     'Clean up
    Set rst = Nothing
    Set dbs = Nothing
End Sub
Private Function RoDBConvert(wType As String)
    If dicDBTranslate Is Nothing Then
        BuildDicDBTranslate
    End If
    RoDBConvert = dicDBTranslate(wType)
End Function
Private Sub BuildDicDBTranslate()
    Set dicDBTranslate = New Scripting.Dictionary
    dicDBTranslate.Add "<STP", "<SP-"
    dicDBTranslate.Add "<MEL", "<MEL-"
    dicDBTranslate.Add "<ARP", "<ARP-"
End Sub
Private Function RoTypeConvert(wType As String) As String
    If dicTypeTranslate Is Nothing Then
        BuildDicTypeTranslate
    End If
    If dicTypeTranslate.Exists(wType) Then
        RoTypeConvert = dicTypeTranslate(wType)
    Else
        RoTypeConvert = "[" + Mid(wType, 4, 1) + "]"
    End If
End Function
Private Sub BuildDicTypeTranslate()
    Set dicTypeTranslate = New Scripting.Dictionary
    dicTypeTranslate.Add "STPV", ".A"
    dicTypeTranslate.Add "STPD", ".B"
    dicTypeTranslate.Add "STPN", ".C"
    
    dicTypeTranslate.Add "MELN", ".A"
    dicTypeTranslate.Add "MELD", ".B"
    dicTypeTranslate.Add "MELR", ".C"
    
    dicTypeTranslate.Add "ARPN", ".A"
    dicTypeTranslate.Add "ARPV", ".B"
    dicTypeTranslate.Add "ARPT", ".C"
    dicTypeTranslate.Add "ARPD", ".D"
End Sub
Function GetARPRO(ro As String, roPrev As String, roNext As String) As String
'<ARP CDS-LT046-MED \n\H>
'<MEL FWS-PL-V037 \d>
'<ARP CDS-LT046-MED \t\h\1>
    Dim roNum As String
    Dim roFlag As String
    roNum = Trim(Left(ro, InStr(ro, "\") - 1))
    roFlag = Trim(Mid(ro, InStr(ro, "\")))
    Dim roPNum As String
    Dim roPFlag As String
    If roPrev = "" Then
        roPNum = roPrev
        roPFlag = roPrev
    Else
        roPNum = Trim(Left(roPrev, InStr(roPrev, "\") - 1))
        roPFlag = Trim(Mid(roPrev, InStr(roPrev, "\")))
    End If
    Dim roNNum As String
    Dim roNFlag As String
    If roNext = "" Then
        roNNum = roNext
        roNFlag = roNext
    Else
        roNNum = Trim(Left(roNext, InStr(roNext, "\") - 1))
        roNFlag = Trim(Mid(roNext, InStr(roNext, "\")))
    End If
    If InStr(ro, "\h") > 0 Or InStr(ro, "\l") > 0 Then
        GetARPRO = roNum + GetARPExt(roFlag) + " " + roFlag
    ElseIf roNum = roNNum And InStr(roNext, "\h") > 0 Or InStr(roNext, "\l") > 0 Then
        GetARPRO = roNum + GetARPExt(roNFlag) + " " + roFlag
    ElseIf roNum = roPNum And InStr(roPrev, "\h") > 0 Or InStr(roPrev, "\l") > 0 Then
        GetARPRO = roNum + GetARPExt(roPFlag) + " " + roFlag
    Else
        GetARPRO = ro
    End If
'<ARP CDS-LT046-MED-HI1 \n\H>
End Function
Function GetARPExt(flg As String) As String
    '\t\h\1
    If InStr(flg, "\h") > 0 Then
        GetARPExt = "-HI"
    End If
    If InStr(flg, "\l") > 0 Then
        GetARPExt = "-LO"
    End If
    If InStr(flg, "\1") > 0 Then
        GetARPExt = GetARPExt + "1"
    ElseIf InStr(flg, "\2") > 0 Then
        GetARPExt = GetARPExt + "2"
    ElseIf InStr(flg, "\3") > 0 Then
        GetARPExt = GetARPExt + "3"
    End If
End Function
Function GetType(str As String) As String
    Dim startpt As Integer
    startpt = InStr(str, "<") + 1
    GetType = Mid(str, startpt, 3)
End Function
Function GetRO(str As String) As String
    Dim startpt As Integer
    startpt = InStr(str, "<")
    Dim endpt As Integer
    endpt = InStr(str, ">")
    GetRO = Mid(str, startpt, 1 + endpt - startpt)
End Function
Function GetTxt(txt As String) As String
    txt = Replace(txt, Chr(30), "-")
    Dim startpt As Integer
    startpt = InStr(txt, ">""")
    Dim endpt As Integer
    endpt = InStr(txt, """<")
    GetTxt = Mid(txt, startpt + 2, endpt - startpt - 2)
End Function

Private Sub btnAll_Click()
    Dim dtStart As Date
    dtStart = Now
    Dim cnt As Long
    cnt = 0
    Dim fld As Field
    Set fld = NextRO(Selection.NextField)
    While Not fld Is Nothing
        Dim txt As String
        Dim myType As String
        Dim myRO As String
        Dim myTxt As String
        txt = fld.Code.Text
        tbNext.Text = GetNextText(fld)
        tbPrevious.Text = GetPreviousText(fld)
        myType = GetType(txt)
        myRO = GetRO(txt)
        myTxt = GetTxt(txt)
        ProcessField fld, myRO, myTxt, tbPrevious.Text, tbNext.Text
        If tbPROMSRO.Text <> "" Then
            Selection.Text = tbPROMSRO.Text
            cnt = cnt + 1
        End If
        Set fld = NextRO(Selection.NextField)
    Wend
    tbRO.Text = ""
    tbText.Text = ""
    Beep
    Dim secs As Integer
    secs = DateDiff("s", dtStart, Now)
    MsgBox CStr(cnt) + " RO converted in " + CStr(secs) + " seconds", vbOKOnly, "End of Document"
End Sub
Private Sub btnConvert_Click()
    If tbPROMSRO.Text <> "" Then
        Selection.Text = tbPROMSRO.Text
        btnFindRO_Click
    End If
End Sub
Private Sub btnFindRO_Click()
    continueProcessing = False
    Dim fld As Field
    Set fld = NextRO(Selection.NextField)
    If fld Is Nothing Then
        If continueProcessing Then
            Exit Sub
        End If
        tbRO.Text = ""
        tbText.Text = ""
        Beep
        MsgBox "No more ROs", vbOKOnly, "End of Document"
        Exit Sub
    End If
    Dim txt As String
    Dim myType As String
    Dim myRO As String
    Dim myTxt As String
    txt = fld.Code.Text
    tbNext.Text = GetNextText(fld)
    tbPrevious.Text = GetPreviousText(fld)
    myType = GetType(txt)
    myRO = GetRO(txt)
    myTxt = GetTxt(txt)
    ProcessField fld, myRO, myTxt, tbPrevious.Text, tbNext.Text
End Sub
Private Function NextRO(fld As Field) As Field
    Set NextRO = Nothing
TopOfNextRO:
    While Not (fld Is Nothing)
        DoEvents
        On Error GoTo myEH
        If Mid(fld.Code.Text, 1, 8) = " QUOTE <" Then
            Dim txt As String
            Dim myType As String
            Dim myRO As String
            txt = fld.Code.Text
            If tbSearch.TextLength = 0 Or InStr(txt, tbSearch.Text) > 0 Then
                myType = GetType(txt)
                myRO = GetRO(txt)
                If myType = "STP" Then  'setpoint
                    Set NextRO = fld
                    Exit Function
                ElseIf myType = "MEL" Then  'equipment
                    Dim p As Integer
                    p = InStr(myRO, "\")
                    If p > 0 Then
                        Dim s As String
                        s = UCase(Mid(myRO, p + 1, 1))
                        If InStr("NRDC", s) > 0 Then
                            Set NextRO = fld
                            Exit Function
                        End If
                    End If
                ElseIf myType = "ARP" Then  'alarm
                   Set NextRO = fld
                   Exit Function
                End If
            End If
        End If
        Set fld = fld.Next
        If fld Is Nothing Then
            Set fld = Selection.NextField
            'ActiveWindow.Activate
        End If
    Wend
    Exit Function
myEH:
    'ActiveWindow.Activate
    Set fld = Selection.NextField
    GoTo TopOfNextRO
End Function
Sub ShowMyself()
    vlnWestROConvert.Show
End Sub
Sub BuildROList()
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
     
     'Establish connection
    Set dbs = OpenDatabase("c:\vewest\westfields.mdb")
     'Fill recordset
    Set rst = dbs.OpenRecordset("Select * FROM APPARPFieldsNotInROs_qry")
     
     'Fill combo by looping through the recordset
    Do While Not rst.EOF
        Debug.Print rst.Fields(0)
        rst.MoveNext
    Loop
     
     'Clean up
    Set rst = Nothing
    Set dbs = Nothing

End Sub

Private Sub btnLoad_Click()
    BuildROList
End Sub