' AID 44624

' April 6, 2011

' Rockwell Automation

' FactoryTalk View 6.0 CPR9 SR3

Option Explicit

Private Const ROOT As String = "/"

' **** USER-CONFIGURABLE ENTRIES START HERE ****

'First HMI Server

Private Const HMISERVERNAME As String = "InstantFizz_HMI" 'sample HMI server name - change to
actual name

Private Const HMIAREANAME As String = "/HMI_Area" 'sample area for HMI server - change to
actual name

'First Data Server (includes Device-Based FTAE)

Private Const DATASERVERNAME As String = "RSLinx Enterprise" 'default OPC Data server name -
change to actual name

Private Const DATAAREANAME As String = "/Data_Area" 'sample

'First Tag-Based FTAE Server, if defined

Private Const FTAETAGSERVERNAME As String = "FTAETag_Server" 'sample Tag-Based FTAE server

name - change to actual name

Private Const FTAETAGAREANAME As String = "/FTAETag_Area" 'sample area for Tag-Based FTAE
server - change to actual name
Private Const NUMBEROFHMISERVERS = 1 'max = 1, modify to suit actual number of HMI
servers in app

Private Const NUMBEROFDATASERVERS = 1 'max = 1, modify to suit actual number of DATA

servers in app, with or without FTAE enabled

Private Const NUMBEROFFTAETAGSERVERS = 1 'max = 1, modify to suit actual number of

FTAE Tag-Based servers in app

' Total number is the number of your servers + 1 for the FactoryTalk Directory.

' For example: HMI Server, Data Server (RSLinx), Tag-Based A&E = 3 + 1 for FTD

' Example total would be 4.

Private Const NUMBEROFSERVERGROUPS = 4

' **** USER-CONFIGURABLE ENTRIES END HERE ****

'max number of servers our screen is configured for.

Private Const MAXNUMBEROFSERVERGROUPS = 4

'Second HMI Server, if defined

Private Const HMISERVERNAME_2 As String = "N/A" 'sample HMI server name - change to actual
name

Private Const HMIAREANAME_2 As String = "N/A" 'sample area for HMI server - change to actual
name

'Second Data Server, if defined (includes Device-Based FTAE)

Private Const DATASERVERNAME_2 As String = "N/A" 'default OPC Data server name - change to actual
name

Private Const DATAAREANAME_2 As String = "N/A" 'sample

'Second Tag-Based FTAE Server, if defined

Private Const FTAETAGSERVERNAME_2 As String = "N/A" 'sample Tag-Based FTAE server name -
change to actual name

Private Const FTAETAGAREANAME_2 As String = "N/A" 'sample area for Tag-Based FTAE server -
change to actual name

'Assignments of GRP constants used to display graphics

' GRP_x assignments correspond to the graphic. If you reorganize or

' want to reassign, you'll have to go through the code reassign everywhere.

Private Const GRP_1 = 1 'Group1 status-state indicator - FTD

' HMI Server

Private Const GRP_2 = 2 'Group2 status-state indicator - HMI Server

' Data Server

Private Const GRP_3 = 3 'Group3 status-state indicator - Data Server

' FTAE Tag-Based

Private Const GRP_4 = 4 'Group4 status-state indicator - FTAE Tag-Based

' HMI Server 2

Private Const GRP_5 = 5 'Group5 status-state indicator - HMI Server 2

' Data Server 2

Private Const GRP_6 = 6 'Group6 status-state indicator - Data Server 2

' FTAE Tag-Based 2

Private Const GRP_7 = 7 'Group7 status-state indicator - FTAE Tag-Based 2

Private sHMIAreaName As String 'default HMI area

Private sHMISvrName As String 'default HMI server

Private sHMIAreaName_2 As String 'default HMI area

Private sHMISvrName_2 As String 'default HMI server

Private sDATAreaName As String 'default Data area

Private sDATSvrName As String 'default Data server

Private sDATAreaName_2 As String 'default Data area

Private sDATSvrName_2 As String 'default Data server

Private sFTAETagAreaName As String 'FTAE Area

Private sFTAETagSvrName As String 'FTAE Server

Private sFTAETagAreaName_2 As String 'FTAE Area

Private sFTAETagSvrName_2 As String 'FTAE Server

'adding 1 to array definition since all our indexing starts with 1 instead of 0.

Private sAreaName(MAXNUMBEROFSERVERGROUPS + 1) As String

Private sServername(MAXNUMBEROFSERVERGROUPS + 1) As String

Private sFullServerName(MAXNUMBEROFSERVERGROUPS + 1) As String

Private WithEvents appStatus As Application 'app events used to update real time status

Private sHMIArray(NUMBEROFHMISERVERS + 1) As String 'array to search multiple HMI servers +

1 b/c search starts at 1
Private sDATAArray(NUMBEROFDATASERVERS + 1) As String 'array to search multiple DATA servers
+ 1 b/c search starts at 1

Private sFTAETagArray(NUMBEROFFTAETAGSERVERS + 1) As String 'array to search multiple DATA

servers + 1 b/c search starts at 1

Private Sub Display_AnimationStart()

Dim lGroup As Long

On Error GoTo ErrHandler

'general initialization

'appStatus ServiceDisruption/ServiceRecovery events used to update real time status

Set appStatus = Me.Application

'initialize for default servers

sHMIAreaName = HMIAREANAME

sHMISvrName = HMISERVERNAME

sFTAETagAreaName = FTAETAGAREANAME

sFTAETagSvrName = FTAETAGSERVERNAME

sDATAreaName = DATAAREANAME

sDATSvrName = DATASERVERNAME

'array only required if using more than one server of each type
'if multiple servers populate arrays with all respective servernames

If NUMBEROFHMISERVERS > 0 Then

sHMIArray(1) = sHMISvrName

HMI_Group2.Visible = True

Else

HMI_Group2.Visible = False

End If

If NUMBEROFDATASERVERS > 0 Then

sDATAArray(1) = sDATSvrName

Data_Group3.Visible = True

Else

Data_Group3.Visible = False

End If

If NUMBEROFFTAETAGSERVERS > 0 Then

sFTAETagArray(1) = sFTAETagSvrName

FTAETag_Group4.Visible = True

Else

FTAETag_Group4.Visible = False

End If

'set default status for GRP_1 server: FTD

sAreaName(GRP_1) = "Not Applicable"

sServername(GRP_1) = "FTDirectory"

sFullServerName(GRP_1) = sServername(GRP_1)

'set default status for GRP_2 server: HMI Server

sAreaName(GRP_2) = sHMIAreaName

sServername(GRP_2) = sHMISvrName

sFullServerName(GRP_2) = sAreaName(GRP_2) & ":" & sServername(GRP_2)

'set default status for GRP_3 server: Data Server

sAreaName(GRP_3) = sDATAreaName

sServername(GRP_3) = sDATSvrName

sFullServerName(GRP_3) = sAreaName(GRP_3) & ":" & sServername(GRP_3)

'set default status for GRP_4 server: FTAE Tag-Based

sAreaName(GRP_4) = sFTAETagAreaName

sServername(GRP_4) = sFTAETagSvrName

sFullServerName(GRP_4) = sAreaName(GRP_4) & ":" & sServername(GRP_4)

For lGroup = 1 To MAXNUMBEROFSERVERGROUPS

ConfigServerStatus lGroup

ConfigServerState lGroup

Next
 Exit Sub

ErrHandler:

LogDiagnosticsMessage "VBA Error (Display_AnimationStart()): " & Hex(Err.Number) & " - " &
Err.Description, ftDiagSeverityError

End Sub

Private Sub appStatus_ServerStateChanged(ByVal Area As String, ByVal ServerName As String, ByVal

ComputerName As String, ByVal State As gfxServerStateConstants)

Dim lGroup As Long

For lGroup = 1 To NUMBEROFSERVERGROUPS

ConfigServerState lGroup

Next

End Sub

Private Sub appStatus_ServiceDisruption(ByVal Area As String, ByVal ServerName As String, ByVal

ComputerName As String)

Dim lGroup As Long

For lGroup = 1 To NUMBEROFSERVERGROUPS

ConfigServerStatus lGroup

Next

End Sub

Private Sub appStatus_ServiceRecovery(ByVal Area As String, ByVal ServerName As String, ByVal

ComputerName As String)

Dim lGroup As Long

 For lGroup = 1 To NUMBEROFSERVERGROUPS

ConfigServerStatus lGroup

Next

End Sub

Private Sub Display_BeforeAnimationStop()

Set appStatus = Nothing

End Sub

Public Sub SetServerStatus(lGroup As Long, sscStatus As gfxServerStatusConstants, bPrimaryServer As

Boolean)

Dim sObjectName As String

On Error GoTo ErrHandler

'determine whether primary or secondary

If bPrimaryServer Then

sObjectName = "polyPrimaryStatus"

Else

sObjectName = "polySecondaryStatus"

End If

'set status colour

If sscStatus = gfxServerStatusActive Then

Elements.Item(sObjectName & lGroup).BackColor = vbGreen

ElseIf sscStatus = gfxServerStatusStandby Then

Elements.Item(sObjectName & lGroup).BackColor = vbYellow

 ElseIf sscStatus = gfxServerStatusOutOfService Then

Elements.Item(sObjectName & lGroup).BackColor = vbRed

Else

Elements.Item(sObjectName & lGroup).BackColor = vbBlack

End If

Exit Sub

ErrHandler:

LogDiagnosticsMessage "VBA Error (SetServerStatus()): " & Hex(Err.Number) & " - " & Err.Description,
ftDiagSeverityError

End Sub

Public Sub ConfigServerStatus(lGroup As Long)

Dim strActiveComputerName As String

Dim sscPrimaryStatus As gfxServerStatusConstants

Dim sscSecondaryStatus As gfxServerStatusConstants

On Error GoTo ErrHandler

'Display name of application

txtApplicationName.Caption = Application.ApplicationName

'determining server status and name

GetServerStatus sFullServerName(lGroup), sscPrimaryStatus, sscSecondaryStatus,

strActiveComputerName

Elements.Item("txtAreaName" & lGroup).Caption = sAreaName(lGroup)

 Elements.Item("txtServerName" & lGroup).Caption = sServername(lGroup)

Elements.Item("txtComputerName" & lGroup).Caption = strActiveComputerName

SetServerStatus lGroup, sscPrimaryStatus, True

SetServerStatus lGroup, sscSecondaryStatus, False

Exit Sub

ErrHandler:

Select Case Hex(Err.Number)

Case 80040488

sscPrimaryStatus = gfxServerStatusOutOfService

sscSecondaryStatus = gfxServerStatusSecondaryNotDefined

strActiveComputerName = "Server NOT found!"

Resume Next

Case Else

LogDiagnosticsMessage "VBA Error (ConfigServerStatus()): " & Hex(Err.Number) & " - " &
Err.Description, ftDiagSeverityError

End Select

End Sub

Public Sub ConfigServerState(lGroup As Long)

Dim sscPrimaryState As gfxServerStateConstants

Dim sscSecondaryState As gfxServerStateConstants

On Error GoTo ErrHandler

GetServerState sFullServerName(lGroup), sscPrimaryState, sscSecondaryState

 SetServerState lGroup, sscPrimaryState, True

SetServerState lGroup, sscSecondaryState, False

Exit Sub

ErrHandler:

Select Case Hex(Err.Number)

Case 80040490

sscPrimaryState = gfxServerStateNotLoaded

sscSecondaryState = gfxServerStateSecondaryNotDefined

Resume Next

Case Else

LogDiagnosticsMessage "VBA Error (ConfigServerState()): " & Hex(Err.Number) & " - " &
Err.Description, ftDiagSeverityError

End Select

End Sub

Public Sub SetServerState(lGroup As Long, sscState As gfxServerStateConstants, bPrimaryServer As

Boolean)

Dim sObjectName As String

Dim bFTServer As Boolean

On Error GoTo ErrHandler

'determine whether primary or secondary

If bPrimaryServer Then

sObjectName = "txtPrimaryState"
 Else

sObjectName = "txtSecondaryState"

End If

'determine whether FTserver

If StrComp(UCase(Elements.Item("txtServerName" & lGroup).Caption), "FTDIRECTORY",

vbTextCompare) = 0 Then

bFTServer = True

Else

bFTServer = False

End If

With Elements.Item(sObjectName & lGroup)

Select Case sscState

Case gfxServerStateActive

.ForeColor = vbBlack

.Caption = "Active"

Case gfxServerStateActiveNoPartner

.ForeColor = vbBlack

If bFTServer Then

.Caption = "Active" 'FTServer cannot be made redundant: will never have partner

Else

.Caption = "Active - No Partner"

End If

Case gfxServerStateActiveSync

.ForeColor = vbBlack
 .Caption = "Active - Synchronizing"

Case gfxServerStateCommError

.ForeColor = vbBlack

.Caption = "Communication Error"

Case gfxServerStateLoading

.ForeColor = vbBlack

.Caption = "Server Loading"

Case gfxServerStateNotInUse

.ForeColor = vbBlack

.Caption = "Out of Service - Manual"

Case gfxServerStateNotLoaded

.ForeColor = vbBlack

.Caption = "Server Not Loaded"

Case gfxServerStateOutofService

.ForeColor = vbBlack

.Caption = "Out of Service - Failure"

Case gfxServerStateReady

.ForeColor = vbBlack

.Caption = "Ready"

Case gfxServerStateReadyToBeActive

.ForeColor = vbBlack

.Caption = "Ready to be Active"

Case gfxServerStateReadyToBeStandby

.ForeColor = vbBlack

.Caption = "Ready to be Standby"

 Case gfxServerStateStandby

.ForeColor = vbBlack

.Caption = "Standby"

Case gfxServerStateStandbySync

.ForeColor = vbBlack

.Caption = "Standby - Synchronizing"

Case gfxServerStateStarting

.ForeColor = vbBlack

.Caption = "Server Starting"

Case gfxServerStateSecondaryNotDefined

.ForeColor = vbWhite

If bFTServer Then

.Caption = "Not Applicable"

Else

.Caption = "Secondary Not Defined"

End If

Case Else

.ForeColor = vbWhite

.Caption = "Not Defined"

End Select

End With

Exit Sub

ErrHandler:

LogDiagnosticsMessage "VBA Error (SetServerState()): " & Hex(Err.Number) & " - " & Err.Description,
ftDiagSeverityError
End Sub

Public Function SelectServer(lGroup As Long) As Boolean

Dim sTemp As String

Dim bServerSelected As Boolean

On Error GoTo ErrHandler

bServerSelected = False

'determine applicable group default area

If lGroup = 2 Then

sTemp = sHMIAreaName

ElseIf lGroup = 3 Then

sTemp = sDATAreaName

ElseIf lGroup = 4 Then

sTemp = sFTAETagSvrName

ElseIf lGroup = 5 Then

sTemp = sHMIAreaName_2

ElseIf lGroup = 6 Then

sTemp = sDATAreaName_2

ElseIf lGroup = 7 Then

sTemp = sFTAETagSvrName_2

Else
 sTemp = ROOT

End If

sTemp = InputBox("Enter name of Area: ", , sTemp)

'if no area defined proceed only if FTDirectory

If sTemp = "" Or sTemp = "Not Applicable" Then

sTemp = InputBox("Enter server name: ", , "FTDirectory")

If StrComp(UCase(sTemp), "FTDIRECTORY", vbTextCompare) = 0 Then

sAreaName(lGroup) = "Not Applicable"

sServername(lGroup) = sTemp

sFullServerName(lGroup) = sServername(lGroup)

bServerSelected = True

End If

Else

sAreaName(lGroup) = Trim(sTemp)

'determine applicable group default server

If lGroup = 2 Then

sTemp = sHMISvrName

ElseIf lGroup = 3 Then

sTemp = sDATSvrName

ElseIf lGroup = 4 Then

sTemp = sFTAETagSvrName

ElseIf lGroup = 5 Then

sTemp = sHMISvrName_2
 ElseIf lGroup = 6 Then

sTemp = sDATSvrName_2

ElseIf lGroup = 7 Then

sTemp = sFTAETagSvrName_2

Else

sTemp = "FTDirectory"

End If

sTemp = InputBox("Enter server name: ", , sTemp)

If sTemp <> "" Then

If StrComp(UCase(sTemp), "FTDIRECTORY", vbTextCompare) = 0 Then

sAreaName(lGroup) = "Not Applicable"

sServername(lGroup) = sTemp

sFullServerName(lGroup) = sServername(lGroup)

bServerSelected = True

Else

sServername(lGroup) = Trim(sTemp)

sFullServerName(lGroup) = sAreaName(lGroup) & ":" & sServername(lGroup)

bServerSelected = True

End If

End If

End If

SelectServer = bServerSelected
 Exit Function

ErrHandler:

LogDiagnosticsMessage "VBA Error (SelectServer()): " & Hex(Err.Number) & " - " & Err.Description,
ftDiagSeverityError

SelectServer = False

End Function

Public Sub ConfigColumnHeadings(lGroup As Long)

Dim lServ As Long

Dim bItemFound As Boolean

On Error GoTo ErrHandler

bItemFound = False

If StrComp(UCase(sServername(lGroup)), "FTDIRECTORY", vbTextCompare) = 0 Then

Elements.Item("txtServer" & lGroup).Caption = "FT Server"

Else

For lServ = 1 To NUMBEROFHMISERVERS

If StrComp(UCase(sHMIArray(lServ)), UCase(sServername(lGroup)), vbTextCompare) = 0 Then

Elements.Item("txtServer" & lGroup).Caption = "HMI Server"

bItemFound = True

End If

Next lServ

If bItemFound Then Exit Sub

 For lServ = 1 To NUMBEROFDATASERVERS

If StrComp(UCase(sDATAArray(lServ)), UCase(sServername(lGroup)), vbTextCompare) = 0 Then

Elements.Item("txtServer" & lGroup).Caption = "Data Server"

bItemFound = True

End If

Next lServ

For lServ = 1 To NUMBEROFFTAETAGSERVERS

If StrComp(UCase(sFTAETagArray(lServ)), UCase(sServername(lGroup)), vbTextCompare) = 0 Then

Elements.Item("txtServer" & lGroup).Caption = "Data Server"

bItemFound = True

End If

Next lServ

If Not bItemFound Then

Elements.Item("txtServer" & lGroup).Caption = "Server"

End If

End If

Exit Sub

ErrHandler:

LogDiagnosticsMessage "VBA Error (ConfigColumnHeadings()): " & Hex(Err.Number) & " - " &
Err.Description, ftDiagSeverityError

End Sub

Private Sub btnServer2_Released()

 Dim bServerSelected As Boolean

bServerSelected = SelectServer(GRP_2)

If bServerSelected Then

ConfigColumnHeadings GRP_2

ConfigServerStatus GRP_2

ConfigServerState GRP_2

End If

End Sub

Private Sub btnServer3_Released()

Dim bServerSelected As Boolean

bServerSelected = SelectServer(GRP_3)

If bServerSelected Then

ConfigColumnHeadings GRP_3

ConfigServerStatus GRP_3

ConfigServerState GRP_3

End If

End Sub

Private Sub btnServer4_Released()

Dim bServerSelected As Boolean

bServerSelected = SelectServer(GRP_4)
 If bServerSelected Then

ConfigColumnHeadings GRP_4

ConfigServerStatus GRP_4

ConfigServerState GRP_4

End If

End Sub