diff --git a/PROMS/VEPROMS User Interface/MSWordVBA/VlnWROMacros.bas b/PROMS/VEPROMS User Interface/MSWordVBA/VlnWROMacros.bas index 9c557c65..c7955010 100644 --- a/PROMS/VEPROMS User Interface/MSWordVBA/VlnWROMacros.bas +++ b/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 diff --git a/PROMS/VEPROMS User Interface/MSWordVBA/vlnWestROConvert.frm b/PROMS/VEPROMS User Interface/MSWordVBA/vlnWestROConvert.frm new file mode 100644 index 00000000..edb408ab --- /dev/null +++ b/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) = " 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 " +' +' + 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 +' +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 diff --git a/PROMS/VEPROMS User Interface/MSWordVBA/vlnWestROConvert.frx b/PROMS/VEPROMS User Interface/MSWordVBA/vlnWestROConvert.frx new file mode 100644 index 00000000..670ab9fc Binary files /dev/null and b/PROMS/VEPROMS User Interface/MSWordVBA/vlnWestROConvert.frx differ