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

示例程序可执行文件只能在日语和英语操作系统上正确运行。要在其他操作系统环境中运行可执行文件，需要在该操作系统环境中重新创建可执行文件。
Visual Basic 6.0程序示例不支持Windows Vista/Windows 7/Windows 8。

Option Explicit

Private Sub Form_Load()

'初始化API。
Dim nResult As Long
nResult = InitRuntimeAPI

' 获取句柄。
ghWinGP = GetRuntimeHandle(9800)
If ghWinGP = 0 Then
  MsgBox ("Unable to get handle")
End If

End Sub

Private Sub Bt_GetStartState_Click()

Screen.MousePointer = vbHourglass

' 获取状态。
Dim Status As Long
Dim RetVal As Long
RetVal = GetRuntimeStartState(ghWinGP, Status)

' Problem?
If RetVal <> CLng(API_ERROR.E_SUCCESS) Then
  MsgBox ("Err(" + Str(RetVal) + "):GetRuntimeStartState()")
End If

' Display status
Select Case Status
  Case 0
   Me.StartState.Text = "Running"
  Case 1
   Me.StartState.Text = "Online"
  Case 2
   Me.StartState.Text = "Offline"
  Case 3
   Me.StartState.Text = "RUN mode"
  Case 4
   Me.StartState.Text = "Exiting"
  Case 5
   Me.StartState.Text = "Inactive"
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)

' Problem?
If RetVal <> API_ERROR.E_SUCCESS Then
  MsgBox ("Err(" + Str(RetVal) + "):GetScreenState()")
End If

' Display status
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)

' Problem?
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)

' Problem?
If RetVal <> API_ERROR.E_SUCCESS Then
  MsgBox ("Err(" + Str(RetVal) + "):GetDisplayScreenNumber()")
End If

' 获取画面号。
Dim ScreenCount As Long
RetVal = GetEnumScreenNumberCount(ghWinGP, ScreenCount)

' Problem?
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)

' 有问题吗？
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

' Display retrieved information
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 '将光标变成沙漏状。

' 退出运行。
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