being aware of the fact that VBA is a subset of VB(6), I usually point
people over at the MSDN downloads. They have a great package of 101 examples
that are generally easily modified for VBA. The unfortunate part is that
database is not on the low end of the scale for challenges but does bring a
great sense of reward when you get them to work. Here's some examples for
VBA DB for create, update, and select.
al
' this subroutine creates a database record using a passed string
' GUID (usually from the pagObj_ShapeAdded event defined in ThisDocument)
Public Sub subCreateDbRecord(strDbTable As String, strIndex As String,
strGUID As String)
Dim intResult As Integer
Dim str_db_filename As String
Dim db As Database
Dim visDocument As Visio.Document
Dim visPage As Visio.Page
Dim SaveErr As Long
Dim errDB As ADODB.Error
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim strProvider As String
Dim strSource As String
Dim strConn As String
Dim strSelect As String
strProvider = "PROVIDER=Microsoft.Jet.OLEDB.4.0;"
strSource = "Data Source="
Dim strProviderED As String ' the end delimter
strProviderED = ";"
On Error GoTo CreateRecord_Err
' first we have to find out which database is associated with this
document
' it is stored in a custom property on the sheet named "project
definition"
Set visDocument = Visio.ActiveDocument
Set visPage = visDocument.Pages.item("Project Definition")
str_db_filename = visDocument.Path &
visPage.PageSheet.Cells("prop.database_file.value").ResultStr("")
' now create the connection string and open the database
strConn = strProvider & strSource & str_db_filename & strProviderED
cnn.Open strConn
' all shape properties will be saved in a table base on group
strSelect = "SELECT * FROM " & strDbTable
rst.Open strSelect, cnn, adOpenKeyset, adLockOptimistic
rst.AddNew
rst.Fields(strIndex) = strGUID
rst.Update
rst.Close
cnn.Close
DoEvents
CreateRecord_Exit:
Exit Sub
CreateRecord_Err:
SaveErr = Err.Number
If SaveErr > 0 Then
Debug.Print "Err in subCreateDbRecord is " & Err & " " & Err.Description
Resume Next
End If
For Each errDB In cnn.Errors
Debug.Print "DB Create"
Debug.Print "DB Description: " & errDB.Description
Debug.Print "DB Number: " & errDB.Number & " (" & _
Hex$(errDB.Number) & ")"
Debug.Print "JetErr: " & errDB.SQLState
Next
End Sub
' this is used by the cell changed event to allow us to just change a
' single cell in a record, rather than full record updates. work in
' progress
Public Sub subDiscreteFieldUpdate(strTable As String, strIndex As String,
strGUID As String, strField As String, strValue As String)
Dim intResult As Integer
Dim str_db_filename As String
Dim db As Database
Dim visDocument As Visio.Document
Dim visPage As Visio.Page
Dim SaveErr As Long
Dim errDB As ADODB.Error
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim strProvider As String
Dim strSource As String
Dim strConn As String
Dim strSelect As String
strProvider = "PROVIDER=Microsoft.Jet.OLEDB.4.0;"
strSource = "Data Source="
Dim strProviderED As String
strProviderED = ";"
On Error GoTo DiscreteField_Exit
'first we have to find out which database is associated with this
document
Set visDocument = Visio.ActiveDocument
Set visPage = visDocument.Pages.item("Project Definition")
str_db_filename = visDocument.Path &
visPage.PageSheet.Cells("prop.database_file.value").ResultStr("")
strConn = strProvider & strSource & str_db_filename & strProviderED
cnn.Open strConn
strSelect = "SELECT * FROM " & strTable & " Where " & strIndex & " =
" & strGUID
rst.Open strSelect, cnn, adOpenKeyset, adLockOptimistic
If (rst.BOF And rst.EOF) Then
' Debug.Print "err discrete field update " & strGUID & " record
not found"
GoTo DiscreteField_Exit
End If
' MsgBox strValue
If strField = "propcost" Then
' Debug.Print "propcost " & Int(strValue)
rst.Fields(strField).Value = Int(strValue)
Else
rst.Fields(strField).Value = strValue
End If
rst.Update
DiscreteField_Exit:
rst.Close
cnn.Close
DoEvents
Exit Sub
DiscreteField_Err:
SaveErr = Err.Number
If SaveErr <> 0 Then
Debug.Print "Err in subDiscreteFieldUpdate is " & Err & " " &
Err.Description
Debug.Print strGUID & " " & strField & " " & strValue
For Each errDB In cnn.Errors
Debug.Print "DB Update " & " " & strGUID & " " & strField & " "
& strValue
Debug.Print "DB Description: " & errDB.Description
Debug.Print "DB Number: " & errDB.Number & " (" & _
Hex$(errDB.Number) & ")"
Debug.Print "JetErr: " & errDB.SQLState
Next
' Resume DiscreteField_Exit:
End If
End Sub
' this is where we take the masterid and do a search
' in the shape table to see if we have a match. The
' table setup is pretty straight forward and works
' as a fair prototype. Originally this was where the
' vent add-on kept track of the different stencils. The
' only change was the addition of a cost field.
Public Function funcTestDbForVent(strGUID As String) As Boolean
Dim visDocument As Visio.Document
Dim visPage As Visio.Page
Dim SaveErr As Long
Dim errDB As ADODB.Error
Dim errNum As Integer
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim errLoop As ADODB.Error
Dim strError As String
Dim strProvider As String
Dim strSource As String
Dim strConn As String
Dim strfind As String
Dim strSelect As String
Dim strValue As String
Dim strField As String
Dim str_db_filename As String
strProvider = "PROVIDER=Microsoft.Jet.OLEDB.4.0;"
strSource = "Data Source="
Dim strProviderED As String ' the end delimiter
strProviderED = ";"
On Error GoTo TestDbForVent_Err
'first we have to find out which database is associated with this
document
Set visDocument = Visio.ActiveDocument
Set visPage = visDocument.Pages.item("Project Definition")
str_db_filename = visDocument.Path &
visPage.PageSheet.Cells("prop.database_file.value").ResultStr("")
' now we can connect to the database
strConn = strProvider & strSource & str_db_filename & strProviderED
cnn.Open strConn
strfind = "ShapeID=" & strGUID & strProviderED
strSelect = "SELECT * FROM tblShapeMaster WHERE " & strfind
rst.Open strSelect, cnn, adOpenKeyset, adLockOptimistic
If (rst.BOF And rst.EOF) Then ' we dont have it in the database
rst.Close
cnn.Close
' Debug.Print "GUID = " & strGUID & " record not found during
vent validate"
funcTestDbForVent = False
Exit Function
End If
' add code here if you want to do something with what came back
' Debug.Print "GUID = " & strGUID & "Found in VENT "
funcTestDbForVent = True
rst.Close
cnn.Close
TestDbForVent_Exit:
DoEvents
Exit Function
TestDbForVent_Err:
' Enumerate Errors collection and display
' properties of each Error object.
For Each errLoop In cnn.Errors
strError = "ADODB Error #" & errLoop.Number & vbCr & _
" " & errLoop.Description & vbCr & _
" (Source: " & errLoop.Source & ")" & vbCr & _
" (SQL State: " & errLoop.SQLState & ")" & vbCr & _
" (NativeError: " & errLoop.NativeError & ")" & vbCr
If errLoop.HelpFile = "" Then
strError = strError & _
" No Help file available" & _
vbCr & vbCr
Else
strError = strError & _
" (HelpFile: " & errLoop.HelpFile & ")" & vbCr & _
" (HelpContext: " & errLoop.HelpContext & ")" & _
vbCr & vbCr
End If
Debug.Print strError
Next errLoop
SaveErr = Err
' object not bound in get_part_id means no unique id could be valid with
no cost
If SaveErr = 91 Then
SaveErr = 0
Err.Clear
Resume Next
End If
If SaveErr <> 0 Then
Debug.Print "Err in TestDbForVent is " & Err & " " & Err.Description
Err.Clear
End If
Resume TestDbForVent_Exit
End Function
