38.5.3.3 VB6程序示例 - 检索WinGP状态以及更改设置示例(专用API)

示例程序位置：(GP-Pro EX CD-ROM)\WinGP\SDK\Pro-SDK\VB\RtCtrlSmpl

Option Explicit
 
Private Sub Form_Load()
 
 '初始化API (API)。
 Dim nResult As Long
 nResult = InitRuntimeAPI
 
 '在此处获取句柄(API)。
 ghWinGP = GetRuntimeHandle(9800)
 If ghWinGP = 0 Then
  MsgBox ("(API) Failed to get handle")
 End If
 
End Sub
 
Private Sub Bt_GetStartState_Click()
 
 Screen.MousePointer = vbHourglass
 
 '获取状态(API)。
 Dim Status As Long
 Dim RetVal As Long
 RetVal = GetRuntimeStartState(ghWinGP, Status)
 
 '有错误吗？
 If RetVal <> CLng(API_ERROR.E_SUCCESS) Then
MsgBox ("Err(" + Str(RetVal) + "):GetRuntimeStartState()")
 End If
 
 '显示状态。
 Select Case Status
 Case 0
 Me.StartState.Text = "Starting"
Case 1
 Me.StartState.Text = "Online"
Case 2
 Me.StartState.Text = "Offline mode"
 Case 3
Me.StartState.Text = "Transfer Mode"
 Case 4
 Me.StartState.Text = "Exiting"
 Case 5
Me.StartState.Text = "Not executing"
 End Select
 
 Screen.MousePointer = vbDefault
 
End Sub
 
Private Sub BT_GetScreenState_Click()
 
 Screen.MousePointer = vbHourglass
 
 '获取状态。
 Dim Status As Long
 Dim RetVal As Long
 RetVal = GetScreenState(ghWinGP, Status)
 
 '有错误吗？
 If RetVal <> API_ERROR.E_SUCCESS Then
MsgBox ("Err(" + Str(RetVal) + "):GetScreenState()")
 End If
 
 '显示状态。
 Select Case Status
Case 0, 1, 2
 Me.ScreenState.ListIndex = Status
 End Select
 
 Screen.MousePointer = vbDefault
 
End Sub
 
Private Sub BT_SetScreenState_Click()
 
 Screen.MousePointer = vbHourglass '将光标变成沙漏状。
 
 ' 获取设置值。
 Dim State As Long
 Dim PosX As Long
 Dim PosY As Long
 Dim Width As Long
 Dim Height As Long
 
 State = Me.ScreenState.ListIndex
 PosX = Val(Me.PosX.Text)
 PosY = Val(Me.PosY.Text)
 Width = Val(Me.TX_Width.Text)
 Height = Val(Me.TX_Height.Text)
 
 '设置画面状态。
 Dim RetVal As Long
 RetVal = SetScreenState(ghWinGP, State, PosX, PosY, Width, Height)
 
 '有错误吗？
 If RetVal <> API_ERROR.E_SUCCESS Then
MsgBox ("Err(" + Str(RetVal) + "):SetScreenState()")
 End If
 
 Screen.MousePointer = vbDefault
 
End Sub
 
Private Sub GetDispScreen_Click()
 
 Screen.MousePointer = vbHourglass '将光标变成沙漏状。
 
 Dim CurScrNo As Long ' 当前画面号。
 
 '获取状态。
 Dim RetVal As Long
 RetVal = GetDisplayScreenNumber(ghWinGP, CurScrNo)
 
 '有错误吗？
 If RetVal <> API_ERROR.E_SUCCESS Then
MsgBox ("Err(" + Str(RetVal) + "):GetDisplayScreenNumber()")
 End If
 
 '获取画面数。
 Dim ScreenCount As Long
 RetVal = GetEnumScreenNumberCount(ghWinGP, ScreenCount)
 
 '有错误吗？
 If RetVal <> API_ERROR.E_SUCCESS Then
MsgBox ("Err(" + Str(RetVal) + "):GetEnumScreenNumberCount()")
 End If
 
 '获取画面号。
 If ScreenCount > 0 Then
 
 '获取画面号。
  Dim ScreenNumber() As Long
ReDim ScreenNumber(ScreenCount - 1) As Long
RetVal = EnumScreenNumber(ghWinGP, ScreenCount, ScreenNumber(0))
 
'有错误吗？
 If RetVal <> API_ERROR.E_SUCCESS Then
 MsgBox ("Err(" + Str(RetVal) + "):EnumScreenNumber()")
End If
 
 ----- 显示状态 -----
 
'设置获取的画面号。
  Me.CB_DispScreen.Clear
Dim idx As Long
For idx = 0 to ScreenCount - 1
 Me.CB_DispScreen.AddItem (ScreenNumber(idx))
 Next
 
'显示当前显示画面的画面号。
  For idx = 0 to ScreenCount - 1
 If CurScrNo = Val(Me.CB_DispScreen.List(idx)) Then
 Me.CB_DispScreen.ListIndex = idx
 Exit For
End If
Next
 
 End If
 
 Screen.MousePointer = vbDefault '将光标恢复原状。

End Sub
 
Private Sub SetDispScreen_Click()
 
 Screen.MousePointer = vbHourglass '将光标变成沙漏状。
 
 '获取画面号。
 Dim ScrNo As Long
 ScrNo = Val(Me.CB_DispScreen.Text)
 
 '更改画面号。
 Dim RetVal As Long
 RetVal = SetDisplayScreenNumber(ghWinGP, ScrNo)
 
 ' Any problems?
 If RetVal <> API_ERROR.E_SUCCESS Then
 MsgBox ("Err(" + Str(RetVal) + "):SetDisplayScreenNumber()")
 End If
 
 '再次获取画面号并将它与设定值作比较，从而确定是否成功更改了画面号。
 Dim NowScrNo As Long
 RetVal = GetDisplayScreenNumber(ghWinGP, NowScrNo)
 If RetVal = API_ERROR.E_SUCCESS Then
If NowScrNo = ScrNo Then
' MsgBox ("Screen Change Successful No=" + Str(NowScrNo))
End If
 End If
 
 Screen.MousePointer = vbDefault '将光标恢复原状。
 
End Sub
 
Private Sub GetProjectInfo_Click()
 
 Screen.MousePointer = vbHourglass '将光标变成沙漏状。
 
'要获取的参数范围。
 Dim ProjectFileName As String * 256
 Dim ProjectComment As String * 256
 Dim ProjectFastTime As String * 256
 Dim ProjectLastTime As String * 256
 Dim ProjectIDownload As String * 256
 Dim HMIEditorVersion As String * 256
 Dim ControlEditorVersion As String * 256
 Dim MakingPerson As String * 256
 
 '获取工程信息。
 Dim RetVal As Long
 RetVal = GetProjctInformation(ghWinGP, _
ProjectFileName, _
ProjectComment, _
ProjectFastTime, _
ProjectLastTime, _
ProjectIDownload, _
HMIEditorVersion, _
 ControlEditorVersion, _
MakingPerson)
 
 ' 有错误吗？
 If RetVal <> API_ERROR.E_SUCCESS Then
 MsgBox ("Err(" + Str(RetVal) + "):GetProjctInformation()")
 End If
 
 '显示获取的信息。
 Me.Prj_File.Text = StrConv(ProjectFileName, vbFromUnicode)
 Me.Prj_Comment.Text = StrConv(ProjectComment, vbFromUnicode)
 Me.Prj_Date.Text = StrConv(ProjectFastTime, vbFromUnicode)
 Me.Prj_LastDate.Text = StrConv(ProjectLastTime, vbFromUnicode)
 Me.Prj_HMI.Text = StrConv(HMIEditorVersion, vbFromUnicode)
 Me.Prj_Person.Text = StrConv(MakingPerson, vbFromUnicode)
 
 Screen.MousePointer = vbDefault '将光标恢复原状。
 
End Sub
 
' 13退出操作。
'退出时显示确认对话框。
' 如果您选择对话框中的“不退出”，则WinGP不会结束。
'即使返回值是API_ERROR.E_SUCCESS。
 
Private Sub StopWinGP_Q_Click()
 Screen.MousePointer = vbHourglass '将光标变成沙漏状。
 
'退出操作(API)。
 Dim RetVal As Long
 RetVal = StopRuntime(ghWinGP, 1)
 
 ' 有错误吗？
 If RetVal <> API_ERROR.E_SUCCESS Then
  MsgBox ("Err(" + Str(RetVal) + "):StopRuntime()")
 End If
 
 Screen.MousePointer = vbDefault ' 将光标恢复原状。
 
End Sub