home
Form1.frm
Author Nigel Rivett
VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 13155
ClientLeft = 165
ClientTop = 555
ClientWidth = 17940
LinkTopic = "Form1"
ScaleHeight = 13155
ScaleWidth = 17940
StartUpPosition = 3 'Windows Default
Begin VB.ComboBox cmbProcedure
Height = 315
Left = 2520
TabIndex = 11
Top = 1920
Width = 3975
End
Begin VB.CommandButton cmdEnd
Caption = "End"
Height = 615
Left = 14520
TabIndex = 10
Top = 1800
Width = 2055
End
Begin VB.ComboBox cmbSchemaCalls
Height = 315
Left = 9120
TabIndex = 8
Top = 840
Width = 3975
End
Begin MSFlexGridLib.MSFlexGrid grdWork
Height = 6735
Left = 1320
TabIndex = 7
Top = 3960
Width = 15135
_ExtentX = 26696
_ExtentY = 11880
_Version = 393216
AllowUserResizing= 3
End
Begin VB.ComboBox cmbDatabase
Height = 315
Left = 2520
TabIndex = 5
Top = 1440
Width = 3975
End
Begin VB.ComboBox cmbConnectionString
Height = 315
Left = 2520
TabIndex = 2
Top = 360
Width = 7095
End
Begin VB.CommandButton cmdGet
Caption = "Get"
Height = 615
Left = 14520
TabIndex = 1
Top = 840
Width = 2055
End
Begin VB.ComboBox cmbType
Height = 315
Left = 2520
TabIndex = 0
Top = 840
Width = 3975
End
Begin VB.Label Label5
Caption = "Procedure"
Height = 255
Left = 240
TabIndex = 12
Top = 1920
Width = 2055
End
Begin VB.Label Label4
Caption = "SchemaCalls"
Height = 255
Left = 6840
TabIndex = 9
Top = 840
Width = 2055
End
Begin VB.Label Label3
Caption = "Database"
Height = 255
Left = 240
TabIndex = 6
Top = 1440
Width = 2055
End
Begin VB.Label Label2
Caption = "Call Type"
Height = 255
Left = 240
TabIndex = 4
Top = 840
Width = 2055
End
Begin VB.Label Label1
Caption = "Connection String"
Height = 255
Left = 240
TabIndex = 3
Top = 360
Width = 1935
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim aArray() As String
Private Sub GetConnectionProperties()
Dim DBCon As adodb.Connection
Set DBCon = Connect()
Dim objRs As adodb.Recordset
Dim OpenResultSet As adodb.Recordset
Dim objCmd As adodb.Command
Dim adoPrm As adodb.Parameter
Dim objFld As adodb.Field
Dim i As Integer
Text1 = ""
For i = 0 To DBCon.Properties.Count - 1
Text1 = Text1 & i & " - " & DBCon.Properties(i).Name & " - " & DBCon.Properties(i).Value & vbCrLf
Next
End Sub
Private Sub GetSchema()
Dim DBCon As adodb.Connection
Set DBCon = Connect()
Dim objRs As adodb.Recordset
Dim OpenResultSet As adodb.Recordset
Dim objCmd As adodb.Command
Dim adoPrm As adodb.Parameter
Dim objFld As adodb.Field
Dim i As Integer
Set objRs = DBCon.OpenSchema(cmbSchemaCalls.ItemData(cmbSchemaCalls.ListIndex))
PopulateGrid grdWork, objRs, -1
Set objRs = Nothing
Exit Sub
' Debug.Print DBCon.Properties("DBMS Name")
Set objRs = DBCon.OpenSchema(adSchemaProcedureParameters)
'Set objRs = DBCon.OpenSchema(adSchemaProcedureColumns)
Do While Not objRs.EOF And i < 500
i = i + 1
Debug.Print "rec " & i
For Each objFld In objRs.Fields
Debug.Print objFld.Name & "=" & objFld.Value
Next
objRs.MoveNext
Loop
Set objCmd = New adodb.Command
objCmd.ActiveConnection = DBCon
objCmd.CommandText = "select * from "
' objCmd.CommandType = adCmdStoredProc
objCmd.CommandType = adCmdText
'If gTrace = True Then
' dStartTime = Now
' iStartTime = Timer
'End If
Set objRs = objCmd.Execute
'If gTrace = True Then
' dEndTime = Now
' iEndTime = Timer
'End If
Set objRs.ActiveConnection = Nothing
Set OpenResultSet = objRs
Set objRs = Nothing
Set objCmd = Nothing
' If gTrace = True Then
' iFile = FreeFile
' Open App.Path & "\Logs\trace" & Format(Now, "yyyymmdd") & ".txt" For Append As iFile
' Print #iFile, "DB Access - start = " & dStartTime & " end = " & dEndTime & " time = " & Format(iEndTime - iStartTime, "##0.000000") & " secs, proc = " & sProcName
' Close iFile
' End If
End Sub
Private Sub GetDatabases()
Dim DBCon As adodb.Connection
Set DBCon = Connect()
Dim objRs As adodb.Recordset
Dim OpenResultSet As adodb.Recordset
Dim objCmd As adodb.Command
Dim adoPrm As adodb.Parameter
Dim objFld As adodb.Field
Set objRs = DBCon.OpenSchema(adSchemaCatalogs)
PopulateGrid grdWork, objRs, -1
objRs.MoveFirst
cmbDatabase.Clear
cmbDatabase.AddItem ""
Do While Not objRs.EOF
cmbDatabase.AddItem objRs.Fields("CATALOG_NAME").Value
objRs.MoveNext
Loop
cmbDatabase.ListIndex = 0
Set objRs = Nothing
End Sub
Private Sub GetProcedures()
Dim DBCon As adodb.Connection
Set DBCon = Connect()
Dim objRs As adodb.Recordset
Dim OpenResultSet As adodb.Recordset
Dim objCmd As adodb.Command
Dim adoPrm As adodb.Parameter
Dim objFld As adodb.Field
Set objRs = DBCon.OpenSchema(adSchemaProcedures)
PopulateGrid grdWork, objRs, -1
objRs.MoveFirst
cmbProcedure.Clear
cmbProcedure.AddItem ""
Do While Not objRs.EOF
cmbProcedure.AddItem objRs.Fields("PROCEDURE_NAME").Value
objRs.MoveNext
Loop
cmbProcedure.ListIndex = 0
Set objRs = Nothing
End Sub
Private Sub GetProcedureParameters()
Dim DBCon As adodb.Connection
Set DBCon = Connect()
Dim objRs As adodb.Recordset
Dim OpenResultSet As adodb.Recordset
Dim objCmd As adodb.Command
Dim adoPrm As adodb.Parameter
Dim objFld As adodb.Field
Set objRs = DBCon.OpenSchema(adSchemaProcedureParameters)
PopulateGrid grdWork, objRs, -1, "PROCEDURE_NAME", cmbProcedure.Text
End Sub
Private Sub GetProcedureResultset()
Dim DBCon As adodb.Connection
Set DBCon = Connect()
Dim objRs As adodb.Recordset
Dim OpenResultSet As adodb.Recordset
Dim objCmd As adodb.Command
Dim adoPrm As adodb.Parameter
Dim objFld As adodb.Field
Dim objParam As adodb.Parameter
If cmbProcedure = "" Then
MsgBox "must select a procedure"
Exit Sub
End If
Set objCmd = New adodb.Command
objCmd.ActiveConnection = DBCon
objCmd.CommandText = cmbProcedure
objCmd.CommandType = adCmdStoredProc
objCmd.Parameters.Refresh
Load frmWork
Dim i As Long
Dim j As Long
ReDim aArray(1 To 3, 0 To 0) As String
i = 0
For Each objParam In objCmd.Parameters
i = i + 1
ReDim Preserve aArray(1 To 3, 0 To i) As String
aArray(1, i) = objParam.Name
aArray(2, i) = objParam.Value
aArray(3, i) = objParam.Type
Next
frmWork.Getdata aArray()
frmWork.Show vbModal
i = 0
For Each objParam In objCmd.Parameters
i = i + 1
objParam.Value = aArray(2, i)
Next
DBCon.Execute "begin tran" ' make sure don't update database
'DBCon.Execute "set fmtonly on" ' only works if no temp tables in SP
Set objRs = objCmd.Execute
If objRs.Fields.Count > 0 Then
PopulateGrid grdWork, objRs, 0
Else
MsgBox "no resultset"
End If
'DBCon.Execute "set fmtonly off"
DBCon.Execute "rollback tran"
End Sub
Private Sub cmdEnd_Click()
End
End Sub
Private Sub cmdGet_Click()
On Error GoTo ErrHnd
If cmbType.Text = "Connection Properties" Then
GetConnectionProperties
End If
If cmbType.Text = "Schema" Then
GetSchema
End If
If cmbType.Text = "Get Databases" Then
GetDatabases
End If
If cmbType.Text = "Get Procedures" Then
GetProcedures
End If
If cmbType.Text = "Get ProcedureParameters" Then
GetProcedureParameters
End If
If cmbType.Text = "Get ProcedureResultset" Then
GetProcedureResultset
End If
Exit Sub
ErrHnd:
MsgBox Err.Description
Exit Sub
End Sub
Private Sub Form_Activate()
Dim sServer As String
Dim sUser As String
Dim sPWD As String
Dim sDatabase As String
Dim i As Long
Dim j As Integer
Dim o As adodb.SchemaEnum
sServer = "(local)"
sDatabase = "elmcrest"
sUser = "testuser"
sPWD = "testpwd"
cmbConnectionString.AddItem "Provider=sqloledb;" & "server=" & sServer & ";uid=" & sUser & ";pwd=" & sPWD & ";database=" & sDatabase
cmbConnectionString.AddItem "Provider=msdasql;data source=LocalServer"
cmbConnectionString.AddItem "Provider=msdasql;data source=AccessTest"
cmbConnectionString.ListIndex = 1
cmbType.AddItem "Connection Properties"
cmbType.AddItem "Schema"
cmbType.AddItem "Get Databases"
cmbType.AddItem "Get Procedures"
cmbType.AddItem "Get ProcedureParameters"
cmbType.AddItem "Get ProcedureResultset"
cmbType.ListIndex = 0
Dim TLIApp As TLIApplication
Dim ADOTLI As TypeLibInfo
Set TLIApp = New TLIApplication
Set ADOTLI = TLI.TypeLibInfoFromFile("c:\program files\common files\system\ado\msado15.dll") '(TLInfo.Guid, TLInfo.MajorVersion, TLInfo.MinorVersion, 1024)
For i = 1 To ADOTLI.Constants.Count
If ADOTLI.Constants(i).Name = "SchemaEnum" Then
Exit For
End If
Next
For j = 1 To ADOTLI.Constants(i).Members.Count
Select Case ADOTLI.Constants(i).Members(j).Name
Case "adSchemaTables", "adSchemaProcedures", "adSchemaFunctions"
cmbSchemaCalls.AddItem ADOTLI.Constants(i).Members(j).Name
cmbSchemaCalls.ItemData(cmbSchemaCalls.NewIndex) = ADOTLI.Constants(i).Members(j).Value
End Select
Next
For j = 1 To ADOTLI.Constants(i).Members.Count
cmbSchemaCalls.AddItem ADOTLI.Constants(i).Members(j).Name
cmbSchemaCalls.ItemData(cmbSchemaCalls.NewIndex) = ADOTLI.Constants(i).Members(j).Value
Next
cmbSchemaCalls.ListIndex = 0
End Sub
Private Function Connect() As adodb.Connection
Dim DBCon As adodb.Connection
Set DBCon = New adodb.Connection
DBCon.ConnectionString = cmbConnectionString.Text
DBCon.CursorLocation = adUseClient
DBCon.Open
If cmbDatabase <> "" Then
DBCon.DefaultDatabase = cmbDatabase.Text
End If
Set Connect = DBCon
End Function
Private Sub PopulateGrid(grdWork As MSFlexGrid, objRs As adodb.Recordset, Optional iRows As Long, Optional sField As String, Optional sValue As String)
Dim iRow As Long
Dim iCol As Long
Dim iGetRec As Boolean
grdWork.Clear
grdWork.Cols = objRs.Fields.Count
grdWork.Rows = 1
For iCol = 0 To objRs.Fields.Count - 1
grdWork.TextMatrix(0, iCol) = objRs.Fields(iCol).Name
Next
iRow = 0
Do While Not objRs.EOF And (iRow < iRows Or iRows = -1)
iGetRec = False
If sField = "" Then
iGetRec = True
Else
If objRs.Fields(sField) = sValue Then
iGetRec = True
End If
End If
If iGetRec = True Then
iRow = iRow + 1
grdWork.Rows = iRow + 1
For iCol = 0 To objRs.Fields.Count - 1
grdWork.TextMatrix(iRow, iCol) = "" & objRs.Fields(iCol).Value
Next
End If
objRs.MoveNext
Loop
End Sub
Public Sub Getdata()
Dim i As Long
For i = 1 To UBound(aArray, 2)
aArray(2, i) = frmWork.txtValue(i)
Next
End Sub
home