38.5.3.3 VB6 プログラム例 - WinGPの状態を取得 / 設定変更するサンプル(ハンドリングAPI)

サンプルプログラムの場所 : (GP-Pro EXのDVD-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)ハンドルを取得できませんでした")
 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 = "起動中"
  Case 1
   Me.StartState.Text = "オンライン"
  Case 2
   Me.StartState.Text = "オフライン"
  Case 3
   Me.StartState.Text = "転送モード"
  Case 4
   Me.StartState.Text = "終了中"
  Case 5
   Me.StartState.Text = "未動作"
 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)
 
 ' 異常あり?
 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 ("画面は正常に変わりました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