Added MSWord form to help convert W Fields to Word ROs

PROMS/VEPROMS User Interface/MSWordVBA/VlnWROMacros.bas

@@ -1,8 +1,12 @@
 Attribute VB_Name = "VlnWROMacros"
 Sub FindWRO()
 ' FindWRO Macro
-	vlnNextROForm.Show
+    vlnNextROForm.Show
+End Sub
+Sub ConvertWRO()
+    ' Convert WRO Macro
+    vlnWestROConvert.Show
 End Sub
 Public Sub RunAgain()
-  vlnNextROForm.btnNext2_Click
+    vlnNextROForm.btnNext2_Click
 End Sub

PROMS/VEPROMS User Interface/MSWordVBA/vlnWestROConvert.frm

@@ -0,0 +1,471 @@
+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