このファイルには注釈付きのEssbase Visual Basic APIプログラムが含まれています。この基本的なサンプル・プログラムは、Visual Basicプログラミング環境でより多機能なプログラムを作成するための開始点として使用できます。
このファイルは『Oracle Essbase APIリファレンス』と併用して、APIプログラミングの基本的な点を示します。実際のVBコード・ファイル一式は、このドキュメントのsamplesディレクトリにもあります。
注： | このサンプル・プログラムでは更新、レポート、および計算スクリプトが使用されます。デフォルト設定では、Essbaseサーバーはこの種のスクリプトが接続先のデータベースのアプリケーション/データベース・ディレクトリにあると仮定しています。このサンプル・プログラムでは、これが$ARBORPATH/App/Sample/Basicディレクトリです。サーバーが次にスクリプト・ファイルを検索するのが、プログラムが実行中のディレクトリです。標準的なOracle Essbaseのインストールには、calcdat.txtデータ・ロード・ファイルがありますが、他のスクリプト・ファイルは$ARBORPATH/Docs/Api/Samples/vbexecs/V3Reportから$ARBORPATH/App/Sample/Basicにコピーする必要があります。他の場所にファイルを配置することもできますが、その場合はプログラム内で絶対パス名を指定する必要があります。 |
このコードはフォーム自体に付属しています。Code.bas(後続)の関数を呼び出します。Code.basは他のプロジェクトに含めることもできます。
Sub cmdStart_Click()
Call Code.ESB_Init ' Initializes ESB_INIT_T and calls EsbInit()
Call ESB_Login ' EsbLogin() sets server, user and password
Call SetAfterLogin
End Sub
Sub cmdStop_Click()
Call ESB_Logout ' Should logout all login IDs (context handles)
Call ESB_Term ' EsbTerm() terminates the API
Call lstMessagesClear
Call SetBeforeStart
End Sub
Sub cmdClearMsg_Click()
lstMessages.Clear 'Clear Messages
End Sub
Sub cmdCalcFile_Click()
Call ESB_CalcFile 'Calculate
End Sub
Sub cmdClrData_Click()
Call ESB_SetActive 'Set the active database before calling EsbClearDatabase()
Call ESB_ClrData 'Clear data
End Sub
Sub cmdLdData_Click()
MsgBox "WAIT!! Don't do anything until this process completes. Click OK and wait about 15 seconds. "
Call ESB_LdData 'Import Data
End Sub
Sub cmdQryFile_Click()
Call ESB_QryFile
End Sub
Sub cmdQryStr_Click()
Call ESB_QryStr
End Sub
Sub cmdQryStrs_Click()
' Call QryStrs
Call ESB_BeginReport ' 1. EsbBeginReport()
Call ESB_SendString ' 2. EsbSendString() - for each string in the report spec
Call ESB_EndReport ' 3. EsbEndReport()
'*** Display returned data strings; assumes EsbBeginReport()'s ouput flag is TRUE
If lngStatus = 0 Then ' If EsbEndReport() succeeded, call EsbGetString()
Call ESB_GetString ' Server outputs data if intWhetherOutput = ESB_TRUE;
' ESB_GetString calls EsbGetString() to read the returned
' data until an empty string is returned
End If
End Sub
Sub cmdUpdFile_Click()
Call ESB_UpdFile
End Sub
Sub Form_Load()
Call SetBeforeStart
End Sub
Sub SetBeforeStart()
'*** Enable cmdStart
cmdStart.Enabled = True
'*** Disable everything else
cmdStop.Enabled = False
cmdClearMsg.Enabled = False
lstMessages.Enabled = False
cmdCalcFile.Enabled = False
cmdClrData.Enabled = False
cmdLdData.Enabled = False
cmdQryStr.Enabled = False
cmdQryStrs.Enabled = False
cmdQryFile.Enabled = False
cmdUpdFile.Enabled = False
End Sub
Sub SetAfterLogin()
'*** Disable cmdStart
cmdStart.Enabled = False
'*** Enable everything else
cmdStop.Enabled = True
cmdClearMsg.Enabled = True
lstMessages.Enabled = True
cmdCalcFile.Enabled = True
cmdClrData.Enabled = True
cmdLdData.Enabled = True
cmdQryStr.Enabled = True
cmdQryStrs.Enabled = True
cmdQryFile.Enabled = True
cmdUpdFile.Enabled = True
End Sub
このコードは、code.basに含まれています。
Option Explicit
'*******************
'RETURN ERROR STATUS
'*******************
Dim lngStatus As Long
'***********
'INIT GLOBAL
'***********
Dim structInit As ESB_INIT_T
Dim lngInstHndl As Long
Dim lngCtxHndl As Long
'*********************
'ESB_GetMESSAGE GLOBAL
'*********************
Dim intMsgLev As Integer
Dim lngMsgNmbr As Long
'******************************************
'ESB_SetACTIVE and ESB_ClearDATABASE GLOBAL
'******************************************
Dim strActiveApp As String
Dim strActiveDb As String
'*********************************************
'Init and turn error handle turned off
'*********************************************
Sub ESB_Init()
ESB_TRUE = 1 ' ESB_TRUE
ESB_FALSE = 0 ' and ESB_FALSE are variables, not constants
'**********************
' Define init structure
'**********************
structInit.Version = ESB_API_VERSION
structInit.MaxHandles = 10
structInit.LocalPath = "$ARBORPATH"
structInit.MessageFile = ""
structInit.ClientError = ESB_TRUE
structInit.ErrorStack = 100
'******************
'Initialize the API
'******************
lngStatus = EsbInit(structInit, lngInstHndl)
'**************
'Error Checking
'**************
If lngStatus = 0 Then
MsgBox "The API is initialized: " & (lngInstHndl)
Else
MsgBox "The API failed to initialize: " & (lngStatus)
End If
End Sub
'*******************************************************
'Login in user Admin. All login parameters are hardcoded
'*******************************************************
Sub ESB_Login()
Dim strServer As String * ESB_SVRNAMELEN
Dim strUser As String * ESB_USERNAMELEN
Dim strPassword As String * ESB_PASSWORDLEN
Dim intNumAppDb As Integer
strServer = "Localhost"
strUser = "Admin"
strPassword = "password"
lngStatus = EsbLogin(lngInstHndl, _
strServer, strUser, strPassword, _
intNumAppDb, _
lngCtxHndl)
'**************
'Error Checking
'**************
If lngStatus = 0 Then
MsgBox "Admin is logged in, with login ID (context handle) " & (lngCtxHndl) _
& Chr$(10) & "WAIT! DO NOTHING!" _
& Chr$(10) & "Retrieving login status; setting Sample/Basic as active"
'*************************************************
'Call the SetActive routine to select Sample Basic
'*************************************************
Call ESB_ListErrorStackMsgs ' Even successful logins return useful messages
Call ESB_SetActive
Else
MsgBox "Login failed: " & (lngStatus)
End If
End Sub
'**************************************************
'Sets the caller's active application and database.
'**************************************************
Sub ESB_SetActive()
Dim intUserAccess As Integer
strActiveApp = "Sample"
strActiveDb = "Basic"
lngStatus = EsbSetActive(lngCtxHndl, strActiveApp, strActiveDb, intUserAccess)
'**************
'Error Checking
'**************
If lngStatus = 0 Then
MsgBox (strActiveApp) & "/" & (strActiveDb) & " is now active"
Else
MsgBox "EsbSetActive() failed: " & (lngStatus)
End If
End Sub
'*******
' Logout
'*******
Sub ESB_Logout()
lngStatus = EsbLogout(lngCtxHndl)
'**********************************************
'Display whether the logout succeeded or failed
'**********************************************
If lngStatus = 0 Then
MsgBox "Admin, with login ID (context handle) " & (lngCtxHndl) _
& ", is logged out"
Else
MsgBox "EsbLogout() failed: " & (lngStatus)
End If
End Sub
'*****************************
' Terminate the VB API
'*****************************
Sub ESB_Term()
EsbTerm (lngInstHndl)
'**********************************
'Display whether the API terminated
'**********************************
If lngStatus = 0 Then
MsgBox "The API is terminated"
Else
MsgBox "EsbTerm() failed: " & (lngStatus)
End If
End Sub
'***********************************************
'Gets a string of data from the active database.
'***********************************************
Sub ESB_GetString()
Const intDStringLen = 256
Dim strDataString As String * intDStringLen
Dim intNumGSCalls As Integer
intNumGSCalls = 1
lngStatus = EsbGetString(lngCtxHndl, strDataString, intDStringLen)
'***************************************************************
'Call EsbGetString() until an empty string (no data) is returned
'***************************************************************
Do While Mid$(strDataString, 1, 1) <> Chr$(0)
If lngStatus = 0 Then
MsgBox "EsbGetString() call #" & (intNumGSCalls) & " just read the string" _
& Chr$(10) & (strDataString) ' The server's translation of the query string
lstMessages (strDataString) ' Display each returned string on a line
intNumGSCalls = intNumGSCalls + 1 ' Increment now often EsbGetString() is called
Else
MsgBox "EsbGetString() failed: " & (lngStatus)
End If
lngStatus = EsbGetString(lngCtxHndl, strDataString, intDStringLen)
Loop
End Sub
'********************************************************************
'EsbSendString() sends a string of data to the active database.
'This function should be called after EsbBeginReport(),EsbBeginUpdate(),
'or EsbBeginCalc()
'**********************************************************************
Sub ESB_SendString()
Dim strQueryString As String
Dim arrQueryStrings(1 To 8) As String
Dim intCounter As Integer
arrQueryStrings(1) = "<PAGE (Market, Measures) "
arrQueryStrings(2) = "<COLUMN (Year, Scenario) "
arrQueryStrings(3) = "<ROW (Product) "
arrQueryStrings(4) = "<ICHILD Market "
arrQueryStrings(5) = "Qtr1 Qtr2 "
arrQueryStrings(6) = "Actual Budget Variance "
arrQueryStrings(7) = "<ICHILD Product "
arrQueryStrings(8) = "!"
'*****************************************************
'Send a series of query strings to the active database
'*****************************************************
For intCounter = 1 To 8
strQueryString = arrQueryStrings(intCounter)
lngStatus = EsbSendString(lngCtxHndl, strQueryString)
'**************
'Error Checking
'**************
If lngStatus = 0 Then
MsgBox "EsbSendString() sent query string # " & (intCounter) _
& " to the active database"
lstMessages (strQueryString)
Else
MsgBox "EsbSendString() failed: " & (lngStatus)
Exit Sub
End If
Next
End Sub
'****************************************************************
'Sends a report specification to the active database from a file
'****************************************************************
Sub ESB_QryFile()
Dim lngDbCtxHndl As Long
Dim lngRFCtxHndl As Long
Dim strAppName As String
Dim strDbName As String
Dim strReportFile As String
Dim intWhetherOutput As Integer
Dim intWhetherLock As Integer
lngDbCtxHndl = lngCtxHndl
lngRFCtxHndl = lngCtxHndl
strAppName = "Sample"
strDbName = "Basic"
strReportFile = "MyRpt01"
intWhetherOutput = ESB_TRUE ' If TRUE, data is output from server
intWhetherLock = ESB_FALSE ' If TRUE, blocks are locked for update
' If both are FALSE, report spec checked for syntax
lngStatus = EsbReportFile(lngDbCtxHndl, lngRFCtxHndl, strAppName, strDbName, _
strReportFile, intWhetherOutput, intWhetherLock)
'**************
'Error Checking
'**************
If lngStatus = 0 Then
MsgBox "The report file" & Chr$(10) & (strReportFile) & Chr$(10) _
& "was sent to " & (strAppName) & (strDbName) & Chr$(10) _
& "EsbGetString() will read the data"
'******************************************************************************
'Calls EsbGetString to read the returned data until an empty string is returned
'******************************************************************************
Call ESB_GetString
Else
MsgBox "EsbReportFile() failed: " & (lngStatus)
End If
End Sub
'**********************************************************************
'Sends a report specification to the active database as a single string
'**********************************************************************
Sub ESB_QryStr()
Dim intWhetherOutput As Integer
Dim intWhetherLock As Integer
Dim strQueryString As String
strQueryString = "<DESC Year !" ' One query string
intWhetherOutput = ESB_TRUE ' If TRUE, data is output from server
intWhetherLock = ESB_FALSE ' If TRUE, blocks are locked for update
' If both are FALSE, report spec checked for syntax
lngStatus = EsbReport(lngCtxHndl, intWhetherOutput, intWhetherLock, strQueryString)
'**************
'Error Checking
'**************
If lngStatus = 0 Then
MsgBox "The report specification" & Chr$(10) & (strQueryString) & Chr$(10) _
& "was sent to the active database" & Chr$(10) _
& "EsbGetString() will read the data"
'*********************************************************
' Server outputs data if intWhetherOutput = ESB_TRUE;
' ESB_GetString calls EsbGetString() to read the returned
' data until an empty string is returned
'*********************************************************
Call ESB_GetString
Else
MsgBox "EsbReport() failed: " & (lngStatus)
End If
End Sub
'****************************************************************
'Sends an update specification to the active database from a file
'****************************************************************
Sub ESB_UpdFile()
Dim lngDbCtxHndl As Long
Dim lngUFCtxHndl As Long
Dim strAppName As String
Dim strDbName As String
Dim strUpdateFile As String
Dim intWhetherStore As Integer
Dim intWhetherUnlock As Integer
lngDbCtxHndl = lngCtxHndl
lngUFCtxHndl = lngCtxHndl
strAppName = "Sample"
strDbName = "Basic"
strUpdateFile = "CDupdtDb"
intWhetherStore = ESB_TRUE ' Database is updated & data is stored (on server)
intWhetherUnlock = ESB_TRUE ' Locked blocks are unlocked after data is updated
'*******************************************
'Lock database blocks before you update them
'*******************************************
Call ESB_LockDatabase
'******************************************
'Send update file to the specified database
'******************************************
lngStatus = EsbUpdateFile(lngDbCtxHndl, lngUFCtxHndl, strAppName, strDbName, _
strUpdateFile, intWhetherStore, intWhetherUnlock)
'**************
'Error Checking
'**************
If lngStatus = 0 Then
MsgBox "The update file" & Chr$(10) & (strUpdateFile) & Chr$(10) _
& "was sent to " & (strAppName) & (strDbName)
Else
MsgBox "EsbUpdateFile() failed: " & (lngStatus)
End If
'********************************
'Calls error checking sub routine
'********************************
Call ESB_ListErrorStackMsgs
End Sub
'************************************************************
'Starts sending a report specification to the active database
'************************************************************
Sub ESB_BeginReport()
Dim intWhetherOutput As Integer
Dim intWhetherLock As Integer
Dim strQueryString As String
intWhetherOutput = ESB_TRUE ' If TRUE, data is output from server
intWhetherLock = ESB_FALSE ' If TRUE, blocks are locked for update
' If both are FALSE, report spec checked for syntax
lngStatus = EsbBeginReport(lngCtxHndl, intWhetherOutput, intWhetherLock)
'**************
'Error Checking
'**************
If lngStatus = 0 Then
MsgBox "EsbBeginReport() succeeded"
Else
MsgBox "EsbBeginReport() failed: " & (lngStatus)
End If
End Sub
'***********************************************************************
'EsbEndReport marks the end of the report specification sent to the
'active database.
'***********************************************************************
Sub ESB_EndReport()
lngStatus = EsbEndReport(lngCtxHndl)
'**************
'Error Checking
'**************
If lngStatus = 0 Then
MsgBox "EsbEndReport() succeeded"
Else
MsgBox "EsbEndReport() failed: " & (lngStatus)
'********************************
'Calls error checking sub routine
'********************************
Call ESB_ListErrorStackMsgs
Exit Sub
End If
End Sub
'**************************************************************
'Executes a calc script against the active database from a file
'**************************************************************
Sub ESB_CalcFile()
Dim lngDbCtxHndl As Long
Dim lngCSCtxHndl As Long
Dim strAppName As String
Dim strDbName As String
Dim strCalcScriptFile As String
Dim intWhetherCalc As Integer ' If TRUE, the calc script is executed
lngDbCtxHndl = lngCtxHndl
lngCSCtxHndl = lngCtxHndl
strAppName = "Sample"
strDbName = "Basic"
strCalcScriptFile = "Calc5Dim"
intWhetherCalc = ESB_TRUE
lngStatus = EsbCalcFile(lngDbCtxHndl, lngCSCtxHndl, strAppName, strDbName, _
strCalcScriptFile, intWhetherCalc)
'**************
'Error Checking
'**************
If lngStatus = 0 Then
MsgBox (strAppName) & (strDbName) & " is being calculated" & Chr$(10) _
& "using the calc script in " & (strCalcScriptFile)
'*********************************************************
'Call Esb_GetProcessState to get the current state of calc
'*********************************************************
Call ESB_GetProcessState
Else
MsgBox "EsbCalcFile() failed: " & (lngStatus)
'********************************
'Calls error checking sub routine
'********************************
Call ESB_ListErrorStackMsgs
End If
End Sub
'***********************************
'Clear data from the active database
'***********************************
Sub ESB_ClrData()
lngStatus = EsbClearDatabase(lngCtxHndl)
'********************
'Begin error checking
'********************
If lngStatus = 0 Then
MsgBox "WAIT!! Data is being cleared from " & (strActiveApp) & (strActiveDb)
'************************************************************
'Call Esb_GetProcessState to get the current state of process
'************************************************************
Call ESB_GetProcessState
Else
MsgBox "EsbClearDatabase() failed: " & (lngStatus)
'********************************
'Calls error checking sub routine
'********************************
Call ESB_ListErrorStackMsgs
End If
End Sub
'*************************************************
'Import data from different sources
'*************************************************
Sub ESB_LdData()
Dim structRulesFile As ESB_OBJDEF_T
Dim structDataFile As ESB_OBJDEF_T
Dim structSQLSource As ESB_MBRUSER_T
Dim strErrorsOnLoadFile As String
Dim intWhetherAbortOnError As Integer
structDataFile.hCtx = lngCtxHndl
structDataFile.Type = ESB_OBJTYPE_TEXT
structDataFile.AppName = "Sample"
structDataFile.DbName = "Basic"
structDataFile.FileName = "CalcDat"
strErrorsOnLoadFile = "ErrsOnLd.txt"
intWhetherAbortOnError = ESB_TRUE
'********************************************
'Import data from CalcDat.txt to Sample/Basic
'********************************************
lngStatus = EsbImport(lngCtxHndl, structRulesFile, structDataFile, structSQLSource, _
strErrorsOnLoadFile, intWhetherAbortOnError)
'**************
'Error Checking
'**************
If lngStatus = 0 Then
MsgBox "WAIT!! Data from " & (structDataFile.FileName) & Chr$(10) _
& "is being imported to " & (structDataFile.AppName) & (structDataFile.DbName)
'***********************************************************
'Call Esb_GetProcessState to get the current state of import
'***********************************************************
Call ESB_GetProcessState
Else
MsgBox "EsbImport() failed: " & (lngStatus)
'********************************
'Calls error checking sub routine
'********************************
Call ESB_ListErrorStackMsgs
End If
End Sub
'*******************************************************************
' ESB_LockDatabase() calls EsbReportFile() to lock blocks for update
'*******************************************************************
Sub ESB_LockDatabase()
Dim lngDbCtxHndl As Long
Dim lngRFCtxHndl As Long
Dim strAppName As String
Dim strDbName As String
Dim strReportFile As String
Dim intWhetherOutput As Integer ' If TRUE, data is output from server
Dim intWhetherLock As Integer ' If TRUE, blocks are locked for update
lngDbCtxHndl = lngCtxHndl
lngRFCtxHndl = lngCtxHndl
strAppName = "Sample"
strDbName = "Basic"
strReportFile = "CDlockDb"
intWhetherOutput = ESB_FALSE ' FALSE: no data is output from server
intWhetherLock = ESB_TRUE ' TRUE: blocks are locked for update
lngStatus = EsbReportFile(lngDbCtxHndl, lngRFCtxHndl, strAppName, strDbName, _
strReportFile, intWhetherOutput, intWhetherLock)
'**************
'Error Checking
'**************
If lngStatus = 0 Then
MsgBox "The report file" & Chr$(10) & (strReportFile) & Chr$(10) _
& "was sent to " & (strAppName) & (strDbName) & Chr$(10) _
& "Blocks are locked for update" & Chr$(10) _
& "EsbUpdateFile() will update the CalcData database"
Else
MsgBox "EsbReportFile() failed: " & (lngStatus)
'********************************
'Calls error checking sub routine
'********************************
Call ESB_ListErrorStackMsgs
End If
End Sub
'******************************************************************
'Get the current state of an asynchronous process until it finishes
'******************************************************************
Sub ESB_GetProcessState()
Dim structProcessState As ESB_PROCSTATE_T
lngStatus = EsbGetProcessState(lngCtxHndl, structProcessState)
Do Until structProcessState.State = ESB_STATE_DONE
lngStatus = EsbGetProcessState(lngCtxHndl, structProcessState)
Loop
MsgBox "Asynchronous Process Completed"
End Sub
'************************************************************
'This is an error checking subroutine that uses EsbGetMessage
'************************************************************
Sub ESB_ListErrorStackMsgs()
Const intMsgLen = 256
Dim strMsg As String * intMsgLen
lngStatus = EsbGetMessage(lngInstHndl, intMsgLev, lngMsgNmbr, _
strMsg, intMsgLen)
Dim intStackNmbr As Integer
intStackNmbr = 1
'*********************************************************************
'Do while the error stack has messages and drops messages in a ListBox
'*********************************************************************
Do While Mid$(strMsg, 1, 1) <> Chr$(0)
lstMessages "MESSAGE ON ERROR STACK:"
lstMessages "Stack #" & (intStackNmbr)
lstMessages "Level #" & (intMsgLev)
lstMessages "Message #" & (lngMsgNmbr)
lstMessages (strMsg)
intStackNmbr = intStackNmbr + 1
lngStatus = EsbGetMessage(lngInstHndl, intMsgLev, lngMsgNmbr, strMsg, intMsgLen)
Loop
End Sub
Sub lstMessages(strItem As String)
frmRprts.lstMessages.AddItem (strItem)
End Sub
Sub lstMessagesClear()
frmRprts.lstMessages.Clear
End Sub