might try something like this,
al
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
' 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
