diff --git a/PROMS/VEPROMS User Interface/MSWordVBA/VlnWROMacros.bas b/PROMS/VEPROMS User Interface/MSWordVBA/VlnWROMacros.bas new file mode 100644 index 00000000..9c557c65 --- /dev/null +++ b/PROMS/VEPROMS User Interface/MSWordVBA/VlnWROMacros.bas @@ -0,0 +1,8 @@ +Attribute VB_Name = "VlnWROMacros" +Sub FindWRO() +' FindWRO Macro + vlnNextROForm.Show +End Sub +Public Sub RunAgain() + vlnNextROForm.btnNext2_Click +End Sub diff --git a/PROMS/VEPROMS User Interface/MSWordVBA/vlnNextROForm.frm b/PROMS/VEPROMS User Interface/MSWordVBA/vlnNextROForm.frm new file mode 100644 index 00000000..d0d7282a --- /dev/null +++ b/PROMS/VEPROMS User Interface/MSWordVBA/vlnNextROForm.frm @@ -0,0 +1,316 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} vlnNextROForm + Caption = "Find RO" + ClientHeight = 3390 + ClientLeft = 45 + ClientTop = 345 + ClientWidth = 8010 + OleObjectBlob = "vlnNextROForm.frx":0000 + ShowModal = 0 'False + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "vlnNextROForm" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False + + + + +Option Explicit +Dim ContinueProcessing As Boolean + +Private Function GetNextField(fld As Field) As Field + Dim fldNext As Field + On Error GoTo ehNF + Set fldNext = fld.Next + While Not fldNext Is Nothing + Debug.Print "fldNext " + CStr(fldNext.Index) + If (Mid(fldNext.Code.Text, 1, 8) = " QUOTE <") Then + Set GetNextField = fldNext + Exit Function + End If + Set fldNext = fldNext.Next + Wend + Set GetNextField = fldNext + Exit Function +ehNF: + Set GetNextField = Nothing + Exit Function +End Function +Private Function GetPreviousField(fld As Field) As Field + Dim fldPrev As Field + On Error GoTo ehPF + Set fldPrev = fld.Previous + While Not fldPrev Is Nothing + Debug.Print "fldPrev " + CStr(fldPrev.Index) + If (Mid(fldPrev.Code.Text, 1, 8) = " QUOTE <") Then + Set GetPreviousField = fldPrev + Exit Function + End If + Set fldPrev = fldPrev.Previous + Wend + Set GetPreviousField = fldPrev + Exit Function +ehPF: + Set GetPreviousField = Nothing + Exit Function +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 +Private Sub btnNext_Click() +' MousePointer = fmMousePointerHourGlass +' DoEvents +' Dim rng As Range +' Set rng = Selection.Range +' Dim strt As Long +' strt = rng.End +' rng.MoveEnd wdCharacter, ActiveDocument.Characters.Count +' 'Debug.Print str(rng.start) & " - " & str(rng.End) +' Dim flds As Fields +' Set flds = rng.Fields +' 'Debug.Print str(flds.Count) & " Fields" +' Dim fld As Field +' For Each fld In flds +' Dim txt As String +' txt = fld.Code.Text +' If (fld.Code.Start > strt And Mid(fld.Code.Text, 1, 8) = " QUOTE <") Then +' tbNext.Text = GetNextText(fld) +' tbPrevious.Text = GetPreviousText(fld) +' Dim myType As String +' Dim myRO As String +' Dim myTxt As String +' myType = GetType(txt) +' myRO = GetRO(txt) +' myTxt = GetTxt(txt) +' If myType = "STP" Then 'setpoint +' ProcessField fld, myRO, myTxt, tbPrevious.Text, tbNext.Text +' MousePointer = fmMousePointerDefault +' Exit Sub +' ElseIf myType = "MEL" Then 'equipment +'' If InStr(myRO, "\n") > 0 And InStr(myRO, myTxt) > 0 Then 'handle only \n for now and only if text is fullname +' Dim p As Integer +' p = InStr(myRO, "\") +' If p > 0 Then +' Dim s As String +' s = UCase(Mid(myRO, p + 1, 1)) +' If InStr("NRD", s) > 0 Then +' ProcessField fld, myRO, myTxt, tbPrevious.Text, tbNext.Text +' MousePointer = fmMousePointerDefault +' Exit Sub +' End If +' End If +'' If InStr(myRO, "\n") > 0 Then 'handle \n name (short or full) +'' ProcessField fld, myRO, myTxt, tbPrevious.Text, tbNext.Text +'' MousePointer = fmMousePointerDefault +'' Exit Sub +'' End If +'' If InStr(myRO, "\r") > 0 Then 'handle \r room +'' ProcessField fld, myRO, myTxt, tbPrevious.Text, tbNext.Text +'' MousePointer = fmMousePointerDefault +'' Exit Sub +'' End If +'' If InStr(myRO, "\d") > 0 Then 'handle \d description +'' ProcessField fld, myRO, myTxt, tbPrevious.Text, tbNext.Text +'' MousePointer = fmMousePointerDefault +'' Exit Sub +'' End If +' ElseIf myType = "ARP" Then 'alarm +' ProcessField fld, myRO, myTxt, tbPrevious.Text, tbNext.Text +' MousePointer = fmMousePointerDefault +' Exit Sub +' End If +' End If +' Next +' tbRO.Text = "" +' tbText.Text = "" +' Beep +' MousePointer = fmMousePointerDefault +End Sub +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) = " +' +' + 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 +Sub ShowMyself() + vlnNextROForm.Show +End Sub +Public Sub btnNext2_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 + Debug.Print "btnNext2 " + CStr(fld.Index) + 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) + 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("NRD", 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 + End If + Wend + Exit Function +myEH: + ContinueProcessing = True + Application.OnTime DateAdd("s", 2, Now), "RunAgain" + Exit Function +' Set NextRO = NextRO(Selection.NextField) +' Exit Function +' Set fld = Selection.NextField +' GoTo topOfNextRO +End Function +Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) + Unload Me +End Sub diff --git a/PROMS/VEPROMS User Interface/MSWordVBA/vlnNextROForm.frx b/PROMS/VEPROMS User Interface/MSWordVBA/vlnNextROForm.frx new file mode 100644 index 00000000..9c710b0a Binary files /dev/null and b/PROMS/VEPROMS User Interface/MSWordVBA/vlnNextROForm.frx differ