ADO Module
Option Explicit
Private Declare PtrSafe Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Public Function CreateEmptyDB(pathToDB As String)
On Error GoTo LocalErr
Dim oCatalog As Object
Set oCatalog = CreateObject("ADOX.Catalog")
'oCatalog.Create "provider='Microsoft.ACE.OLEDB.12.0';"& "Data Source=C:\NewDB.accdb"
oCatalog.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & pathToDB & ";"
CreateEmptyDB = 1
Exit Function
LocalErr:
MsgBox "Error creating Database " & ThisWorkbookPath & "WOrderDb.mdb"
CreateEmptyDB = Err.Number
End Function
Public Function FormatSQL(vValue As Variant, _
intDataType As Integer, _
Optional strMark As String = "'")
Select Case intDataType
Case 0: 'Boolean
If DBType = DB_USE_MSSQL Then
If vValue = True Then
FormatSQL = 1 'True
ElseIf vValue = False Then
FormatSQL = 0 'False
End If
Else
If vValue = True Then
FormatSQL = -1 'True
ElseIf vValue = False Then
FormatSQL = 0 'False
End If
End If
Case 1: 'Date/Time
If Not IsDate(vValue) Then 'Or IsNull(vValue
'Maybe it is a number
If IsNumeric(vValue) Then
vValue = CDate(vValue)
End If
' If Not IsDate(vValue) Then
' 'Still not a date
' MsgBox "Invalid date value."
' Exit Function
' End If
End If
If DBType = DB_USE_MSSQL Then
If Not IsNull(vValue) Then
'ShortDateSQLFormat
FormatSQL = strMark & Format(vValue, "mm\/dd\/yyyy") & strMark
'LongDateSQLFormat = Format(vValue, "yyyy-mm-dd HH:m:ss.fff")
Else
'Return a `NULL` character value
FormatSQL = "NULL"
End If
Else
'FormatSQL = "#" & Format(vValue, vbShortDate) & "#"
FormatSQL = "#" & Format(vValue, "mm/dd/yyyy") & "#"
End If
Case 2: 'Time
If DBType = DB_USE_MSSQL Then
Else
If Not IsNull(vValue) Then
'FormatSQL = "#" & Format(vValue, vbShortDate) & "#"
FormatSQL = "#" & Format(vValue, "H:mm:ss AM/PM") & "#"
Else
FormatSQL = "NULL"
End If
End If
End Select
End Function
Public Function FormatTimeStampSQL(vValue As Variant, intDataType As Integer)
'If Not IsDate(vValue) Then
If DBType = DB_USE_MSSQL Then
FormatTimeStampSQL = "'" & vValue & "'"
Else
'FormatSQL = "#" & Format(vValue, vbShortDate) & "#"
FormatTimeStampSQL = "#" & Format(vValue, "mm/dd/yyyy H:mm:ss AM/PM") & "#"
End If
'End If
End Function
Public Function ff(pString, Optional pType) As String
' pstring values:
'"S" = quoted string, return empty if blank
'"SN" = quoted string, return NULL if blank
'
'"N" = unqouted Number, return NULL if blank
'
'"DT" = Date/Time, return NULL if d/t is null
'"D" = Date, return NULL if date is null
'"T" = Time, return NULL if time is null
'
If IsMissing(pType) = True Then
ff = "'" & pString & "'"
Else
pType = UCase(pType)
Select Case pType
Case "S"
If IsNull(pString) Then
ff = "''"
Else
ff = "'" & pString & "'"
End If
Case "SN"
If IsNull(pString) Then
ff = "NULL"
Else
ff = "'" & pString & "'"
End If
Case "N"
If IsNull(pString) = True Then
ff = "NULL"
ElseIf Len(Trim(pString)) = 0 Then
ff = "NULL"
Else
ff = pString
End If
Case "DT"
If IsNull(pString) Then
ff = "NULL"
Else
ff = "#" & Format(pString, "MM/DD/YYYY HH:MM:SS") & "#"
End If
Case "D"
If IsNull(pString) Then
ff = "NULL"
Else
ff = "#" & Format(pString, "MM/DD/YYYY") & "#"
End If
Case "T"
If IsNull(pString) Then
ff = "NULL"
Else
ff = "#" & Format(pString, "HH:MM:SS") & "#"
End If
End Select
End If
End Function
Public Function IsValiD(Thing As Object) As Boolean
IsValiD = Not Thing Is Nothing
End Function
Public Sub LinkTable(psTable As String, psFromPath As String, _
psToPath As String)
Dim cnn As ADODB.Connection
Dim cat As ADOX.Catalog
Dim tbl As ADOX.Table
Dim sShortPath As String
'get short path name of the source database
sShortPath = Space(255)
Call GetShortPathName(psFromPath, sShortPath, 255)
sShortPath = Trim$(sShortPath)
sShortPath = Left$(sShortPath, Len(sShortPath) - 1)
'connect to the target database
Set cnn = New ADODB.Connection
With cnn
'.Provider = "Provider=Microsoft.ACE.OLEDB.12.0"
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Data Source") = psToPath
.Open
End With
Set cat = New ADOX.Catalog
Set cat.ActiveConnection = cnn
'link table
Set tbl = New ADOX.Table
With tbl
.Name = psTable
Set .ParentCatalog = cat
.Properties("Jet OLEDB:Create Link") = True
.Properties("Jet OLEDB:Link Datasource") = sShortPath
.Properties("Jet OLEDB:Remote Table Name") = psTable
On Error Resume Next
cat.Tables.Delete psTable
On Error GoTo 0
cat.Tables.Append tbl
End With
Set tbl = Nothing
'release references
cnn.Close
Set cnn = Nothing
Set cat = Nothing
End Sub
Public Function AccessLinkToTable(sLinkFromDB As String, sLinkToDB As String, sLinkToTable As String, Optional sNewLinkTableName As String) As Boolean
Dim CatDB As ADOX.Catalog
Dim TblLink As ADOX.Table
'On Error GoTo ErrFailed
If Len(Dir$(sLinkFromDB)) > 0 And Len(Dir$(sLinkToDB)) > 0 Then
'Databases exist
Set CatDB = New ADOX.Catalog
'Open a Catalog on database in which to create the link.
CatDB.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & sLinkFromDB
Set TblLink = New ADOX.Table
With TblLink
'Name the new Table
If Len(sNewLinkTableName) Then
.Name = sNewLinkTableName
Else
.Name = sLinkToTable
End If
'Set ParentCatalog property to the open Catalog.
'This allows access to the Properties collection.
Set .ParentCatalog = CatDB
'Set the properties to create the link.
.Properties("Jet OLEDB:Create Link") = True
.Properties("Jet OLEDB:Link Datasource") = sLinkToDB
.Properties("Jet OLEDB:Remote Table Name") = sLinkToTable
End With
On Error Resume Next
CatDB.Tables.Delete TblLink
On Error GoTo 0
'Append the table to the Tables collection.
CatDB.Tables.Append TblLink
Set CatDB = Nothing
'Set return as success
AccessLinkToTable = True
End If
' Exit Function
'
'ErrFailed:
' On Error GoTo 0
' AccessLinkToTable = False
End Function
Public Function GetType(e As Integer) As String
Select Case e
Case adBigInt
GetType = "(adBigInt)" ' An 8-byte signed integer"
Case adBinary
GetType = "(adBinary)" ' A binary value"
Case adBoolean
GetType = "Boolean" '"(adBoolean)" A Boolean value"
Case adBSTR
GetType = "(adBSTR)" ' A null-terminated character string (Unicode)"
Case adChar
GetType = "(adChar)" '* A String value"
Case adCurrency
GetType = "Currency" '"(adCurrency)" '* A currency value (8-byte signed integer scaled by 10,000)"
Case adDate
GetType = "Date/Time" '"(adDate)" '* A Date value"
Case adDBDate
GetType = "(adDBDate)" ' A date value (yyyymmdd)"
Case adDBTime
GetType = "(adDBTime)" ' A time value (hhmmss)"
Case adDBTimeStamp
GetType = "(adDBTimeStamp)" ' A date-time stamp (yyyymmddhhmmss plus a fraction in billionths)"
Case adDecimal
GetType = "(adDecimal)" ' An exact numeric value with a fixed precision and scale"
Case adDouble
GetType = "Double" '"(adDouble)" A double-precision floating point value"
Case adEmpty
GetType = "(adEmpty)" ' No value was specified"
Case adError
GetType = "(adError)" ' A 32-bit error code"
Case adGUID
GetType = "ReplicationID" '"(adGUID)" ' A globally unique identifier (GUID)"
Case adIDispatch
GetType = "(adIDispatch)" ' A pointer to an IDispatch interface on an OLE object"
Case adInteger
GetType = "AutoNumber" '"(adInteger)" A 4-byte signed integer"
Case adIUnknown
GetType = "(adIUnknown)" ' A pointer to an IUnknown interface on an OLE object"
Case adLongVarBinary
GetType = "OLE" '"(adLongVarBinary)" A long binary value (Parameter object only)"
Case adLongVarChar
GetType = "(adLongVarChar)" ' A long String value (Parameter object only)"
Case adLongVarWChar
GetType = "Memo" '"(adLongVarWChar)" * Memo A long null-terminated string value (Parameter object only)"
Case adNumeric
GetType = "(adNumeric)" ' An exact numeric value with a fixed precision and scale"
Case adSingle
GetType = "Single" '"(adSingle)" ' A single-precision floating point value"
Case adSmallInt
GetType = "Integer" '"(adSmallInt)" ' A 2-byte signed integer"
Case adTinyInt
GetType = "Byte" '"(adTinyInt)" A 1-byte signed integer"
Case adUnsignedBigInt
GetType = "(adUnsignedBigInt)" ' An 8-byte unsigned integer"
Case adUnsignedInt
GetType = "(adUnsignedInt)" ' A 4-byte unsigned integer"
Case adUnsignedSmallInt
GetType = "(adUnsignedSmallInt)" ' A 2-byte unsigned integer"
Case adUnsignedTinyInt
GetType = "(adUnsignedTinyInt)" ' A 1-byte unsigned integer"
Case adUserDefined
GetType = "(adUserDefined)" ' A user-defined variable"
Case adVarBinary
GetType = "(adVarBinary)" ' A binary value (Parameter object only)"
Case adVarChar
GetType = "(adVarChar)" ' A String value (Parameter object only)"
Case adVariant
GetType = "(adVariant)" ' An OLE Automation Variant"
Case adVarWChar
GetType = "String" '"(adVarWChar)" A null-terminated Unicode character string (Parameter object only)"
Case adWChar
GetType = "(adWChar)" ' A null-terminated Unicode character string"
Case Else
GetType = Str(e) & " = Unrecognized Type"
End Select
End Function
Share This
