Publish date: 2003-03-26
Work with InterBase using the ScriptControl (VB)
'This example demonstrates how to work with table 'employee'
'of the Interbase DB from the ScriptControl.
'Also Its demonstrate how to organize dinamicly adding
'ActiveX objects to the ScriptControl from the script text
'Required:
' 1. LCPI OLE DB Provider for Interbase.
' 2. Microsoft ActiveX Data Objects 2.6
' 3. Microsoft Excel 9.0.
' 4. Employee.ibp with connection parameters to employee.gdb
' 5. Microsoft ScriptControl
' 6. Microsoft XML v4.0.
Sub Sample12()
Dim con As New ADODB.Connection
'open connection to employee.gdb
Set con = New ADODB.Connection
con.Open "file name=" & ThisWorkBook.Path & "\employee.ibp"
con.BeginTrans
'For an example we have placed the source script text in a string variable.
'However in real systems the scripts texts are placed in the database or in files.
'We think that you will not have problems with implementation of
'methods LoadScriptFromDb and LoadScriptFromFile using this code
Dim source_script As String
'use XML tag
'attributes of a <script> tag will be used for ScriptControl parameters identification
'<object> using for dynamic attachment of ActiveX objects to ScriptControl
'![CDATA[ - Section of XML with our script for ScriptControl (this text not parsed)
source_script = _
"<script language=""vbscript"" startpoint=""main"" timeout=""10000"">" & Chr(13) & _
"<object id=""recset"" classid=""ADODB.Recordset""/> " & Chr(13) & _
"<code> " & Chr(13) & _
"<![CDATA[ " & Chr(13) & _
" Option Explicit " & Chr(13) & _
" " & Chr(13) & _
" Sub main() " & Chr(13) & _
" " & Chr(13) & _
" set recset.ActiveConnection=Connection " & Chr(13) & _
" recset.open ""select * from employee"" " & Chr(13) & _
" " & Chr(13) & _
" " & Chr(13) & _
" End Sub " & Chr(13) & _
"]]> " & Chr(13) & _
"</code> " & Chr(13) & _
"</script> "
'create new script control
Dim MScriptControl As New ScriptControl
'****set the parameters****
'this parameter allow to show dialog windows from the script
'like MsgBox or InputBox
MScriptControl.AllowUI = True
'script language (VBScript by default)
MScriptControl.language = "VBScript"
'script timeout (if time executing script > timeout script is finished own work)
MScriptControl.timeout = 10000
'reset script objects
MScriptControl.Reset
'Adding Our Connection object to the script
MScriptControl.AddObject "Connection", con, True
'XML Document
Dim XMLDoc As New DOMDocument40
XMLDoc.loadXML source_script
'XML Node
Dim XMLNode As IXMLDOMNode
Dim i As Integer, j As Integer
'check parse error
If XMLDoc.parseError.errorCode = 0 Then
'ScriptControl parameters
Dim startpoint As String
Dim timeout As Long
Dim language As String
'attributes for dinamic object
Dim id As String
Dim classid As String
'script text
Dim script As String
'script section
With XMLDoc.childNodes.Item(0)
'find script attributes
For i = 0 To .Attributes.Length - 1
'this attribute we set as default
If .Attributes.Item(i).nodeName = "language" Then
language = .Attributes.Item(i).Text
MScriptControl.language = language
'this attribute is required
ElseIf .Attributes.Item(i).nodeName = "startpoint" Then
startpoint = .Attributes.Item(i).Text
'this attribute we set as default
ElseIf .Attributes.Item(i).nodeName = "timeout" Then
On Error Resume Next
timeout = CLng(.Attributes.Item(i).Text)
'if no conversion error
If Not Err And timeout > 0 Then
MScriptControl.timeout = timeout
End If
On Error GoTo 0
End If
Next i
End With
For Each XMLNode In XMLDoc.childNodes.Item(0).childNodes
'search dinamic AxciteX objects declarations and
'source script text
With XMLNode
Select Case .nodeName
'object declarations
Case "object"
id = ""
classid = ""
'find object attributes
For i = 0 To .Attributes.Length - 1
If .Attributes.Item(i).nodeName = "id" Then
id = .Attributes.Item(i).Text
ElseIf .Attributes.Item(i).nodeName = "classid" Then
classid = .Attributes.Item(i).Text
End If
Next i
'add object to ScriptControl
On Error Resume Next
MScriptControl.AddObject id, CreateObject(classid)
If Err Then
MsgBox Err.Number & ": " & Err.Description, vbCritical, _
"Error while trying to add object"
End If
On Error GoTo 0
'code
Case "code"
script = XMLNode.Text
On Error Resume Next
MScriptControl.AddCode script
If Err Then
'syntaxis error
MsgBox MScriptControl.Error.Description & ": " & _
" (string=" & MScriptControl.Error.Line & _
", column=" & MScriptControl.Error.Column & ")", _
vbCritical, "Check Syntaxis"
Debug.Print "----------------- Syntaxis Error ----------------"
Else
'run script without arguments
'if you need IN-parameters use Array method
'with your parameters as second argument
MScriptControl.Run startpoint 'run startpoint procedure
If Err Then
'runtime error
MsgBox MScriptControl.Error.Description & ": " & _
" (string=" & MScriptControl.Error.Line & _
", column=" & MScriptControl.Error.Column & ")", _
vbCritical, "RunTime Error"
Debug.Print "----------------- Run Time Error ----------------"
Else
'if no error then
'work with ScriptControl objects
Dim rs As ADODB.Recordset
'our recordset from script
Set rs = MScriptControl.CodeObject.recset
Do While Not rs.EOF
Debug.Print rs!first_name & " " & _
rs!last_name
rs.MoveNext
Loop
End If
Debug.Print "----------------- All Done ----------------"
End If
On Error GoTo 0
Exit For 'exit from parsing
End Select
End With
Next 'next XMLNode
Else ' parse error
MsgBox XMLDoc.parseError.reason, vbCritical
End If
'Commit Transaction and close Connection
con.CommitTrans
con.Close
End Sub
