ich hatte das nicht selber geschrieben. Ich habe nochmal nachgeschaut und noch folgenden Code gefunden.
Option Explicit
Public Function GetConnection() As ADODB.Connection
Dim conn As New ADODB.Connection
Dim Connection As String
Connection = "DRIVER={MySQL ODBC 5.1 Driver}; SERVER=BMSSV2K1203; DATABASE=speedy7_bms; UID= _
speedy; PWD=; OPTION=4212875; Port=3306;"
conn.Open Connection
If conn.State = adStateOpen Then
Set GetConnection = conn
Else
Debug.Print "Failed to open connection:=[" & Connection & "]."
End If
End Function
Function GetDocumentPath(ByVal myConn As ADODB.Connection, ByVal doc_docno As String, ByRef _
ver_major As Long) As String
'On Error Resume Next
Dim rs As New ADODB.Recordset
Dim sql As String
Dim ver_file As String
sql = "SELECT * FROM dm_document d " & _
"INNER JOIN dm_version v on d.doc_did=v.ver_did and d.doc_rev=v.ver_major and d. _
doc_ver=v.ver_minor " & _
"INNER JOIN dm_doctype dt on d.doc_dtid=dt.dtype_dtid " & _
"INNER JOIN dm_d2c dc on d.doc_did=dc.d2c_did and dc.d2c_parent=1 " & _
"WHERE (d.doc_docno = '" & doc_docno & "') AND (v.ver_status=8)"
'Debug.Print sql
rs.Open sql, myConn, adOpenForwardOnly, adLockReadOnly
If rs.State = adStateOpen And Not rs.EOF Then
ver_file = rs("ver_file")
ver_major = rs("ver_major")
GetDocumentPath = PathCombine(GetContainerPath(myConn, rs("d2c_cid"), Nz(rs(" _
dtype_storage"), "")), ver_file)
End If
End Function
Function GetContainerPath(ByVal myConn As ADODB.Connection, ByVal cid As Long, ByVal rootpath _
As String) As String
'On Error Resume Next
Dim rs As New ADODB.Recordset
Dim sql As String
Dim ctnr_parent As Long
Dim ctnr_name As String
Dim ctype_storage As String
Dim ctnr_storage As String
Set rs = CreateObject("ADODB.Recordset")
sql = "SELECT * FROM dm_container c " & _
"inner join dm_containertype ct on c.ctnr_ctid=ct.ctype_ctid " & _
"WHERE c.ctnr_cid = " & cid
'Debug.Print sql
rs.Open sql, myConn, adOpenForwardOnly, adLockReadOnly
If rs.State = adStateOpen And Not rs.EOF Then
ctnr_parent = Nz(rs("ctnr_parent"), 0)
ctnr_storage = Nz(rs("ctype_storage"), "")
ctnr_storage = Replace(ctnr_storage, "", Nz(rs("ctnr_name"), ""))
ctnr_storage = Replace(ctnr_storage, "", Nz(rs("ctnr_desc"), ""))
ctnr_storage = Replace(ctnr_storage, ".\", "")
GetContainerPath = PathCombine(GetContainerPath(myConn, ctnr_parent, rootpath), _
ctnr_storage)
ElseIf rootpath "" Then
GetContainerPath = rootpath
Else
GetContainerPath = DbLookup(myConn, "vault_basedir", "dm_vault", "")
End If
End Function
' DbLookup (siehe auch Visual Basic Hilfe)
' Mit der DbLookup-Funktion können Sie den Wert eines bestimmten Feldes aus einer bestimmten _
Datensatzgruppe abrufen.
' expr := Ein Ausdruck, der das Feld kennzeichnet, dessen Werte Sie zurückgeben möchten.
' domain := Ein Zeichenfolgenausdruck, der die Gruppe der Datensätze angibt, die die Domäne _
bilden.
' Es kann sich dabei um einen Tabellennamen oder einen Abfragenamen für eine _
Abfrage handeln, die keinen Parameter benötigt.
' criteria:= Ein Zeichenfolgenausdruck, den Sie optional angeben können, um den Datenbereich _
einzuschränken.
Function DbLookup(ByVal conn As ADODB.Connection, ByVal expr As String, ByVal domain As String, _
ByVal criteria As String)
On Error Resume Next
Dim rs As New ADODB.Recordset
Dim sql As String
sql = "SELECT " & expr & " FROM " & domain
If Len(criteria) > 0 Then
sql = sql & " WHERE " & criteria
End If
'DEBUG_LOG "DbLookup:: sql=" & sql
rs.Open sql, conn, adOpenForwardOnly, adLockReadOnly
If rs.State = adStateOpen Then
DbLookup = rs(0).Value
Else
DbLookup = Null
End If
rs.Close
Set rs = Nothing
End Function
Function Nz(Value, ValueIfNull)
If IsNull(Value) Or IsEmpty(Value) Then
Nz = ValueIfNull
Else
Nz = Value
End If
End Function
'PathAddExtension
'Adds a file extension to a path string.
Function PathAddExtension(ByVal strPath As String, ByVal strExtension As String) As String
If PathFindExtension(strPath) = "" Then
PathAddExtension = strPath & strExtension
Else
PathAddExtension = strPath
End If
End Function
Function PathRemoveExtension(ByVal path As String) As String
Dim i1
i1 = InStrRev(path, ".")
If i1 > 0 Then
PathRemoveExtension = Left(path, i1 - 1)
Else
PathRemoveExtension = path
End If
End Function
'PathFindExtension
'Searches a path for an extension.
Public Function PathFindExtension(ByVal strPath As String) As String
Dim pos
pos = InStrRev(strPath, ".")
If pos > 0 Then
PathFindExtension = Mid(strPath, pos)
Else
PathFindExtension = ""
End If
End Function
'PathFindFileName
'Searches a path for a file name
Public Function PathFindFileName(ByVal strPath As String) As String
Dim pos
pos = InStrRev(strPath, "\")
If pos > 0 Then
PathFindFileName = Mid(strPath, pos + 1)
Else
PathFindFileName = ""
End If
End Function
'PathRemoveFileSpec
'Removes the trailing file name and backslash from a path, if it has them.
Function PathRemoveFileSpec(ByVal strPath As String) As String
Dim pos
pos = InStrRev(strPath, "\")
If pos > 0 Then
PathRemoveFileSpec = Left(strPath, pos - 1)
Else
PathRemoveFileSpec = strPath
End If
End Function
'PathFileExists
'Determines whether a path to a file system object such as a file or directory is valid.
Function PathFileExists(ByVal strFile As String) As Boolean
On Error Resume Next
Dim fso As New FileSystemObject
PathFileExists = fso.FileExists(strFile)
End Function
'PathAddBackslash
'Adds a backslash to the end of a string to create the correct syntax for a path.
'If the source path already has a trailing backslash, no backslash will be added.
Function PathAddBackslash(ByVal strPath As String) As String
If Right(strPath, 1) "\" Then
PathAddBackslash = strPath & "\"
Else
PathAddBackslash = strPath
End If
End Function
'PathRemoveBackslash
'Removes the trailing backslash from a given path.
Function PathRemoveBackslash(ByVal strPath As String) As String
If Right(strPath, 1) = "\" Then
PathRemoveBackslash = Left(strPath, Len(strPath) - 1)
Else
PathRemoveBackslash = strPath
End If
End Function
'PathCombine
'Concatenates two strings that represent properly formed paths into one path, as well as any _
relative path pieces.
Function PathCombine(ByVal strPath As String, ByVal strFile As String) As String
While Left(strFile, 1) = "."
If Left(strFile, 3) = "..\" Then
If Len(strPath) = 2 Or (PathIsUNC(strPath) And GetBackslashCount(strPath) = 2) Then
PathCombine = ""
Exit Function
End If
strPath = PathRemoveFileSpec(strPath)
strPath = PathRemoveBackslash(strPath)
strFile = Mid(strFile, 4)
ElseIf Left(strFile, 2) = ".\" Then
strFile = Mid(strFile, 3)
End If
Wend
PathCombine = PathAddBackslash(strPath) & strFile
End Function
Function GetBackslashCount(ByVal strUNC As String)
Dim nCount
Dim i
nCount = 0
For i = 1 To Len(strUNC)
If Mid(strUNC, i, 1) = "\" Then
nCount = nCount + 1
End If
Next
GetBackslashCount = nCount
End Function
'PathIsUNC
'Determines if the string is a valid UNC (universal naming convention) for a server and share _
path.
Function PathIsUNC(ByVal strPath As String) As Boolean
Dim pos
pos = InStr(strPath, "\\")
If pos > 0 Then
PathIsUNC = True
Else
PathIsUNC = False
End If
End Function
Gruß Hajo