Solved

about ADO

Posted on 2002-05-18
3
454 Views
Last Modified: 2013-11-23
hi , iam ADO new user , i want to ask about a problem i face , first when i want to make a connection i use this:

Dim DB As New ADODB.Connection
Dim DBT As New ADODB.Recordset
   
DB.Open "DSN=MS Access Database; DBQ=C:\TestDB\Access.mdb;DefaultDir=C:\TestDB; " _
         & "DriverId=281;FIL=MS Access; MaxBufferSize=2048; PageTimeout=5;UID=admin;"
   
DBT.Open "test_spe", DB, adOpenDynamic, , adCmdTable


and this works but when i want to make a search i tried to use the index an seek but i found that the index and seek methods not supported as i found by using:

DBT.Supports(adIndex) & "   " and DBT.Supports(adSeek)

so i used find method but i found that it is very slow comparing to seek

another problem : i cannot use addnew and update to add records so i used insert into

is there a problem with my code and why index \ seek and addnew \ update not work ?
0
Comment
Question by:ashraf_t
  • 2
3 Comments
 
LVL 17

Accepted Solution

by:
inthedark earned 100 total points
ID: 7019365
DAO is a lot faster than ADO. But using ADO means that your app. is upward scaleable.

Here a are a few tips for a newbie to ADO.

1) Create a class module Name it and Save as zADO.

2) In your app. in a module declare the following:

Global ADO as New zADO

3) Now you just type "ADO." and you get a list of all of your ADO tricks.

4) Following is a sub to register an MDB database. You used DSN, but using native OLE DB means that you can forget about setting up DSN.  Also if MS change the registrtion code you just change one place in your app.

So to open an MDB:

dim ok
dim CN as ADODB.Connection
dim RS as ADODB.Recordset
dim SQL as String

ADO.RegisterMDB "c:\MyFolder\MyData.MDB"
ok = ADO.ConnectOK(CN)

SQL = "Select * from [MyTable]" _
     + "Where [MyField] = """ + ClientCode+ """;"

OK = ADO.OpenRSROOK(CN, RS, SQL) ' Open read only recordset

IF Not OK Then
   ' prblem with your sql
   msgbox ADO.GetLastError(CN)
   if ADO.IDE Then
     stop ' when debugging in IDE
   else
     ' when running in exe nicely handle fault
   end if
End if

5) Use SQL Insert INTO statements to save new records

6) Use SQL Update to change records

7) The problem is how to use replace seek to find and update new records.

Here is the answer:

a) Use SQL Select and Where to recall just the record you need , but this is slow for batch operations.

b) Use find sed function FindOK but this is slow compared to DAO's Seek

c) And here is where you need to get cute.  ADO is designed arround database servers.

Servers are excellent at handling batch commands. So in SQL server you would fire a stored procedure or in an MDB or SQL server

* Insert multiple records into a temp table.
* Use an Update query to Link the tables and update data from your temp table into your master table.

Remember you can insert many records in one Insert Into statement.

8) In ADO ALL TABLES MUST HAVE A PRIMARY KEY

-----------------

Here is the code fo the zADO module, which designed to work in a web-server environment where a program must never crash. See the Examples sub for basic examples of usage.

=========Class zADO

Option Explicit

' ADO handling Class Module zADO
' Created by Nick Young of VIP InterSoft
' October 13th 2000

' This class has been designed to work in a webserver environment where
' a program must never be allowed to crash.

' PLEASE report any bugs to nyoung@vipintersoft.com
' Suggestions, debugs, improvements or enhancements welcome.
' Please register your usage so that you can be sent updates as available

' See the Sub Examples for Usage
 
' You need to Set Project References to:
' Microsoft AtiveX Data Objects
' And optionally a reference to: (Only ADOX features need this)
' Microsoft ADO Ext/ x.x for DLL & Security

 

Public MDBFile As String        ' name of MDB if an access connection is made


Public ConnectionString As String   ' current registered connect string

Dim DBTypeFound As Boolean
Dim mDBType As String
Dim mCN As String           ' current connection details of last open CN
Public MDBName As String    ' set by DBName
Dim mCurrentDateFormat      ' YYYYY-MM-DD HH:NN:SS for usa date formats
                            ' but depends on user login details

Public CommandLogging As Boolean
Public Commands As String


Public Enum MDBVersion
    Jet10 = 1
    Jet11 = 2
    Jet20 = 3
    Jet3x = 4
    Jet4x = 5
End Enum

' For IDE Function
Dim mIDEDone As Boolean
Dim mIDE As Boolean

Function GetTables(CN As ADODB.Connection)

Dim RS As ADODB.Recordset
Dim tb$




Set RS = CN.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty))
Do While Not RS.EOF
    If RS("TABLE_TYPE") = "TABLE" And LCase(RS("TABLE_NAME")) <> "dtproperties" Then
        If Len(tb$) > 0 Then
            tb = tb + ";" + RS("TABLE_NAME")
        Else
            tb = RS("TABLE_NAME")
        End If
    End If
    RS.MoveNext
Loop

GetTables = Split(tb$, ";")


End Function



Public Function BackupDatabaseOK(CN As ADODB.Connection, DatabaseName As String, DestinationFile As String) As Boolean

' Backup a database


Dim SQL As String
Dim OK
Dim RS As ADODB.Recordset

If DBType = "MDB" Then
    On Error Resume Next
   
    FileCopy DatabaseName, DestinationFile
    If Err.Number = 0 Then
        BackupDatabaseOK = True
    Else
        BackupDatabaseOK = False
    End If
Else
   
    SQL = "USE master" + vbCrLf
    SQL = SQL + "EXEC sp_addumpdevice 'disk', 'TMP_Backup', '" + DestinationFile + "'" + vbCrLf
    SQL = SQL + "BACKUP DATABASE " + DatabaseName + " TO TMP_Backup" + vbCrLf
    SQL = SQL + "EXEC sp_dropdevice 'TMP_Backup'" + vbCrLf
    SQL = SQL + "USE " + DatabaseName + vbCrLf
    OK = ExecuteRSSQLOK(CN, RS, SQL)
    If Not OK Then
        BackupDatabaseOK = False
       
        MsgBox GetLastError(CN)
    End If
   
   
    SQL = "USE " + DatabaseName + vbCrLf ' re-issue incase last command did not read the en.d
    OK = ExecuteSQLOK(CN, SQL)
End If

End Function
Public Function CommitTransOK(CN As ADODB.Connection) As Boolean

On Error Resume Next
CN.CommitTrans
If Err.Number <> 0 Then
    CommitTransOK = False
Else
    CommitTransOK = True
End If

End Function

Public Function CreateMDBOK(Optional DBName As String = "", Optional Version As MDBVersion = MDBVersion.Jet4x)

' Create a new mdb
' if the db has been registed already the dbname is not required

Dim Catalog

On Error Resume Next
Set Catalog = CreateObject("ADOX.Catalog")
If Len(DBName) > 0 Then
    RegisterMDB DBName
End If
Catalog.Create ConnectionString

If Err.Number = 0 Then
    CreateMDBOK = True
Else
    CreateMDBOK = False
End If
Set Catalog = Nothing

End Function

Public Property Let CurrentDateFormat(DateFormateString As String)
mCurrentDateFormat = DateFormateString
End Property

Public Property Get DBName(CN As ADODB.Connection) As String

' Returns the database name

' if SQL returs name of database in last connection
' Or the if AccessName.MDB returns AccessName
   



If Len(MDBName) = 0 Then

    MDBName = LeftPart(LeftPart(RightPart(UCase(CStr(CN)), "DATABASE="), ";"), """")
   
    If Len(MDBName) = 0 Then
        MDBName = LeftPart(LeftPart(RightPart(UCase(CStr(CN)), "DATA SOURCE="), ";"), """")
        MDBName = LeftPart(GetFileFromPath(MDBName), ".")
    End If

End If

DBName = MDBName

End Property

Public Sub Examples()

' Sample Code

'======================
' Register a Connection string

Dim ConString As String
Dim OK
Dim CN As ADODB.Connection
Dim RS As ADODB.Recordset
Dim step As Long
Dim SQL As String
Dim ADO As New zADO ' best to place in declarations
step = 1000
ConString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\DATA\TEMP\TEST.MDB;"
ConString = "driver=SQL Server;server=server4;uid=userid;pwd=password;database=databasename;"

ADO.RegisterConnectString ConString
OK = ADO.ConnectOK(CN)
If Not OK Then
    step = 1010
    SQL = ""
    GoTo ErrorExit
End If
ReDim ar(0)
ar = RS.GetRows()

'======================
' Register an MDB database
step = 1020
ADO.RegisterMDB "C:\MyData.MDB"
OK = ADO.ConnectOK(CN)
If Not OK Then
    step = 1030
End If


'======================
' Register a connection string saved in a file
' avoiding the normal bugs with saved connection strings
step = 1020
ADO.RegisterConnectionFile "C:\MyODBC.TXT"
OK = ADO.ConnectOK(CN)
If Not OK Then
    step = 1030
End If


'======================
' Open a read only recordset
SQL = "Select * from mytable;"
OK = ADO.OpenRSROOK(CN, RS, SQL)
If Not OK Then
    step = 2010
    'ReportError "MySub Step 2010", SQL + " ~ " + ADO.GetLastError(CN)
    GoTo ErrorExit
End If

Do While Not RS.EOF
    MsgBox Git(RS("NyNameField")) ' use Git or GitNum  to access a recordset field
    RS.MoveNext
Loop

'======================
' Open a more complex open recordset
SQL = "Select * from mytable;"
OK = ADO.OpenRSOK(CN, RS, SQL, adOpenKeyset, adLockPessimistic, adCmdText)
If Not OK Then
    step = 2030
   
    GoTo ErrorExit
End If

'======================
' Open an update recordset
SQL = "Select * from mytable;"
OK = ADO.OpenRSUpdateOK(CN, RS, SQL)
If Not OK Then
    step = 2030
   
    GoTo ErrorExit
End If


'======================
' Save a new record
'SQL = "Insert into prodstats (pstStock_number, pstStock_code, pstWebConn, pstPageID, pstHits, pstBasket, pstSales, pstDate)"
'SQL = SQL + " Values ("
'SQL = SQL + CStr(StockNumber) + ", '"
'SQL = SQL + ADO.cSQL(StockCode) + "', "
'SQL = SQL + CStr(Session("webconn")) + ", "
'SQL = SQL + CStr(Session("PageID")) + ", "
'SQL = SQL + CStr(Hits) + ", "
'SQL = SQL + CStr(QTYBasket) + ", "
'SQL = SQL + CStr(QTYSold) + ", '"
'SQL = SQL + ADO.cSQLDate(Now) + "');"

OK = ADO.ExecuteSQLOK(CN, SQL, False)
If Not OK Then
     step = 1020
     GoTo ErrorExit
End If

'======================
' Get the Counter/Autonumber/Identity of the last inserted record for CN
'NewRec = ADO.GetADOCounter(CN)

'======================
' Insert new record and get counter in one hit
SQL = "Insert into MyTab (QTY,Price Value) Values (10,13.20,132.00)"
'NewRec = ADO.InsertGetCounter(CN, SQL)


 ' Update an existing client
'SQL = "Update Name Set "
'SQL = SQL + " Last_WebConn_Number = " + CStr(Session("WebConn")) + ","
'SQL = SQL + " Surname = '" + Session("Surname") + "',"
'SQL = SQL + " Title = '" + Session("Title") + "',"
'SQL = SQL + " First_Name ='" + Session("First_Name") + "',"
'SQL = SQL + " Initial =' " + Session("Initial") + "',"
'SQL = SQL + " Day_Telephone = '" + Session("Day_Telephone") + "',"
'SQL = SQL + " Home_Telephone = '" + Session("Home_Telephone") + "',"
'SQL = SQL + " Comment = '" + Session("Comment") + "',"
'SQL = SQL + " Email = '" + Session("Email") + "',"
'SQL = SQL + " dlc = '" + ADO.cSQLDate(Now) + "', " ' date last changed
'SQL = SQL + " newsletter = " + ADO.cSQLBoolean(Session("newsletter")) + ", "
'SQL = SQL + " specialoffers = " + ADO.cSQLBoolean(Session("specialoffers"))
'SQL = SQL + " where number = " + CStr(Session("Name_Number")) + ";"

step = 2010
OK = ADO.ExecuteSQLOK(CN, SQL)
If Not OK Then
    step = 2020
    GoTo ErrorExit
End If
step = 2050

'======================
' handle booleans
'SQL = "Update Fred Set MyBool = " + ADO.cSQLBoolean(Request("MyCheckBox")) ' web page checkbox post
'SQL = "Update Fred Set MyBool = " + ADO.cSQLBoolean(RS("BooleanField")) ' Recordset
'SQL = "Update Fred Set MyBool = " + ADO.cSQLBoolean("Yes")) ' String ' Yes/No Oui/Non True/False
'SQL = "Update Fred Set MyBool = " + ADO.cSQLBoolean(True) ' Boolean values



GoTo Exiter

ErrorExit:

'ReportError "MySub Step: " + CStr(Step), SQL + " ~ " + ADO.GetLastError(CN)

Exiter:

ADO.Destroy RS ' use this incase rs if not open program won't crash
Set CN = Nothing

End Sub

Public Function ReadFile(FileName As String) As String

' Returns the contents of a file

'example
' SData=ADO.ReadFile("C:\MyStuff.txt")
'If Left(sData, 5) = "ERROR" Then
'    MsgBox sData
'    End
'End If

Dim wlfn As Long

wlfn = FreeFile
On Error Resume Next

If Len(Dir(FileName)) > 0 Then
    If Err.Number <> 0 Then
        ReadFile = "ERROR Invalid resource file path: " + FileName + " ~ " + Err.Description
        Exit Function
    End If
    Open FileName For Binary Access Read Shared As #wlfn
    ReadFile = Space$(LOF(wlfn))
    Get wlfn, 1, ReadFile
    Close wlfn
    If Err.Number <> 0 Then
        ReadFile = "ERROR in function ReadFile: " + FileName + " ~ " + Err.Description
        Exit Function
    End If
Else
    ReadFile = "ERROR Missing File " + FileName
End If

End Function

Public Function GetFileFromPath(FullPathName As String) As String
Dim f As String
Dim lr As Long
f = FullPathName
lr = Len(f)
Do While lr > 1
    If Mid(f, lr, 1) = "\" Then
        f = Mid(f, lr + 1)
        Exit Do
    End If
    lr = lr - 1
Loop

GetFileFromPath = f

End Function


Public Property Get DBType() As String

' returns MSSQL for SQL Server
'         MDB for access database

If Not DBTypeFound Then
   
    If InStr(UCase(mCN), "PARADOX") Then
        DBTypeFound = True
        DBType = "PARADOX"
        Exit Property
    End If
   
    Dim a$
   
    a$ = LeftPart(LeftPart(RightPart(UCase(mCN), "DATABASE="), ";"), """")
   
    If Len(a$) > 0 Then
        mDBType = "MSSQL" ' but could be other type of database but not access
    Else
        MDBFile = LeftPart(LeftPart(RightPart(UCase(mCN), "DATA SOurce="), ";"), """")
        If Len(MDBFile) > 0 Then
            mDBType = "MDB"
        Else
            mDBType = "?"
        End If
    End If
    DBTypeFound = True
End If
DBType = mDBType

End Property
Public Function GetSchemas(CN As ADODB.Connection, Optional TableName As String) As String

' Returns all of the scheme stuff for a table
' example.
' Clipboard.Clear : Clipboard.SetText ADO.GetSchemas(CN, "MyTable")


Dim SQL As String
Dim RS As ADODB.Recordset
Dim m$
Dim lc As Long
Dim OK
Dim Flags As Long
Dim bn As String
ReDim bin(8) As Long
Dim ctype As String
Dim tb As String

bin(1) = 1
bin(2) = 2
bin(3) = 4
bin(4) = 8
bin(5) = 16
bin(6) = 32
bin(7) = 64
bin(8) = 128

'TABLE_CATALOG
'TABLE_SCHEMA
'INDEX_NAME
'TYPE
'TABLE_NAME


tb = TableName


'adSchemaPrimaryKeys
'adSchemaColumns
'adSchemaIndexes

m$ = "TABLE:" + Chr$(9) + TableName + vbCrLf

Dim desc$

ctype = "TABLES": desc = "adSchemaTables": GoSub GetDets
ctype = "COLS": desc = "adSchemaColumns": GoSub GetDets
ctype = "PKEYS": desc = "adSchemaPrimayKeys": GoSub GetDets
ctype = "INDEX": desc = "adSchemaIndexes": GoSub GetDets

GetSchemas = m$

Exit Function

GetDets:

m$ = m$ + vbCrLf + desc + vbCrLf + vbCrLf

Select Case ctype
    Case Is = "COLS"
        Set RS = CN.OpenSchema(adSchemaColumns, Array(Empty, Empty, tb, Empty))
    Case Is = "TABLES"
    On Error Resume Next
        Set RS = CN.OpenSchema(adSchemaTables, Array(Empty, Empty, TableName))
        If Err.Number <> 0 Then
        On Error GoTo 0
       
        Return
        End If
    Case Is = "PKEYS"
        Set RS = CN.OpenSchema(adSchemaPrimaryKeys, Array(Empty, Empty, TableName))
    Case Is = "INDEX"
        Set RS = CN.OpenSchema(adSchemaIndexes, Array(Empty, Empty, Empty, Empty, tb))
End Select

If False Then
    SQL = "SELECT  IDENT_SEED(TABLE_NAME) As Seed,"
    SQL = SQL + " IDENT_INCR(TABLE_NAME) AS Increment,"
    SQL = SQL + " TABLE_NAME"
    SQL = SQL + " From INFORMATION_SCHEMA.TABLES"
    SQL = SQL + " WHERE ((TABLE_NAME='" + tb + "')"
    SQL = SQL + " And (OBJECTPROPERTY(OBJECT_ID(TABLE_NAME), 'TableHasIdentity') = 1)"
    SQL = SQL + " AND (TABLE_TYPE = 'BASE TABLE'))"
 '   ok = ADO.OpenRSOK(CN, RS, SQL)
End If

SQL = Space$(2)

For lc = 0 To RS.Fields.Count - 1
    If lc > 0 Then m$ = m$ + Chr$(9)
    m$ = m$ + CStr(RS.Fields(lc).Name)
Next lc

If ctype = "COLS" Then
    For lc = 1 To 8
        m$ = m$ + Chr(9) + "Flag:" + CStr(bin(lc))
    Next lc
End If

m$ = m$ + vbCrLf

Do While Not RS.EOF

    For lc = 0 To RS.Fields.Count - 1
        If lc > 0 Then m$ = m$ + Chr$(9)
        m$ = m$ + Format(RS.Fields(lc))
    Next lc
   
    If ctype = "COLS" Then
        Flags = RS.Fields("COLUMN_FLAGS")
        bn = String(8, "0")
        For lc = 1 To 8
            If Flags And bin(lc) Then
                Mid(bn, lc, 1) = "1"
            End If
            m$ = m$ + Chr(9) + Mid(bn, lc, 1)
        Next lc
    End If
   
    m$ = m$ + vbCrLf
   
    RS.MoveNext
   
Loop

m$ = m$ + vbCrLf

If False Then

    m$ = m$ + vbCrLf
    RS.Close
   
  '  ok = ADO.OpenRSROOK(CN, RS, "Select * from " + tb + ";")
    For lc = 0 To RS.Fields.Count - 1
        m$ = m$ + CStr(RS.Fields(lc).Name) + Chr(9)
        m$ = m$ + CStr(RS.Fields(lc).Type) + vbCrLf
    Next lc
   
    m$ = m$ + vbCrLf
   
    RS.Close
End If

Return

End Function

Public Sub RegisterConnectionFile(FileName As String)

' Use of this sub avoides the problem that of a connection file has been saved
' with extra lines at the end this will cause a crash.

RegisterConnectString Replace(LeftPart(ReadFile(FileName), "$END$"), vbCrLf, "")

End Sub

Public Sub RegisterMDB(AccessMDBFile As String)

' Register an MDB file for ADO operations
' ecample:

'Dim ADO As New zADO
'Dim CN As ADODB.Connection
'Dim RS As ADODB.Recordset

' ADO.RegisterMDB "D:\MyFile.MDB"
' OK = ADO.Connect(CN)
' OK = ADO.OPenRSROOK(CN, RS, SQL)

RegisterConnectString "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + AccessMDBFile + ";"
MDBFile = AccessMDBFile

End Sub

Public Function RestoreDatabaseOK(CN As ADODB.Connection, DatabaseName As String, SourceFile As String) As Boolean

' Restore a database don't try master

Dim SQL As String
Dim OK
Dim RS As ADODB.Recordset

SQL = "USE master" + vbCrLf
SQL = SQL + "EXEC sp_dboption '" + DatabaseName + "', 'offline', 'TRUE'" + vbCrLf
SQL = SQL + "RESTORE DATABASE " + DatabaseName + " FROM DISK = '" + SourceFile + "'" + vbCrLf
SQL = SQL + "EXEC sp_dboption '" + DatabaseName + "', 'offline', 'FALSE'" + vbCrLf

CN.Execute SQL

Set RS = Nothing

End Function


Public Function cSQLBoolean(StringBoolean) As String

' Returns 1 or 0 for and SQL Update string
' Works with boolean or string values.

' examples:

'SQL = "Update Fred Set MyBool = " + ADO.cSQLBoolean(Request("MyCheckBox")) ' web page checkbox post
'SQL = "Update Fred Set MyBool = " + ADO.cSQLBoolean(RS("BooleanField")) ' Recordset
'SQL = "Update Fred Set MyBool = " + ADO.cSQLBoolean("Yes")) ' String ' Yes/No Oui/Non True/False
'SQL = "Update Fred Set MyBool = " + ADO.cSQLBoolean(True) ' Boolean values

If IsNull(StringBoolean) Then
    cSQLBoolean = "0"
    Exit Function
End If
If TypeOf StringBoolean Is CheckBox Then
    If StringBoolean.Value = 1 Then
        cSQLBoolean = "1"
    Else
        cSQLBoolean = "0"
    End If
Else
    ' Yes/No Oui/Non True/False
    If UCase$(Left(CStr(StringBoolean), 1)) = "T" Or UCase(Left(CStr(StringBoolean), 1)) = "Y" Or UCase(Left(CStr(StringBoolean), 1)) = "O" Then
        cSQLBoolean = "1"
    Else
        cSQLBoolean = "0"
    End If
End If
End Function
Public Function LeftPart(WholeString, FindString) As String

Dim pos As Long

pos = InStr(1, WholeString, FindString, vbTextCompare)
If pos = 0 Then
    LeftPart = WholeString
ElseIf pos = 1 Then
    LeftPart = ""
Else
    LeftPart = Left$(WholeString, pos - 1)
End If

End Function


Public Function RestoreWithMoveOK(CN As ADODB.Connection, _
       backupFile As String, _
       oldDBName As String, oldData As String, oldLog As String, _
       newDB As String, newData As String, newLog As String)

' Here is the SQL Server TSQL Command

'RESTORE DATABASE [NewDBName] FROM  DISK = N'D:\YourBackup.BAK' WITH  FILE = 1,  NOUNLOAD ,  STATS =
'10,  RECOVERY ,  MOVE N'YourOldDB_Data' TO N'D:\YourNewFileLocaltion\NewDBName.mdf',  MOVE N'YourOldDB_log'
'TO N'D:\YourNewFileLocaltion\NewDBName_log.ldf'

'How to use:

'backupfile = "d:\all.bak"

'olddb = "OldDBName"
'oldData = "OldDBName_data" ' find these from current database properties
'oldLog = "OldDBName_log"

'newdb = "NewName"
'newData = "d:\newdb_data.mdf"
'newLOG = "d:\newdb_log.mdf"

'OK = RestoreWithMoveOK(CN, backupFile, oldDBName, oldData, oldLog, _
  newDB, newData, newLog)
Dim SQL As String

SQL = "USE MASTER" + vbCrLf
SQL = SQL + "GO" + vbCrLf
SQL = SQL + "RESTORE DATABASE [$DB$] FROM  DISK = N'$BACKUP$'"
SQL = SQL + " WITH  FILE = 1,  NOUNLOAD ,  STATS = 10,"
SQL = SQL + " RECOVERY ,  MOVE N'$OLDDATA' TO "
SQL = SQL + " N'$NEWDATAFILE$',  MOVE N'$OLDLOG$' TO '$NEWLOGFILE'"

SQL = Replace(SQL, "$DB$", newDB)
SQL = Replace(SQL, "$BACKUP$", backupFile)
SQL = Replace(SQL, "$OLDDATA$", oldData)
SQL = Replace(SQL, "$OLDLOG$", oldLog)
SQL = Replace(SQL, "$NEWDATAFILE$", newData)
SQL = Replace(SQL, "$NEWLOGFILE$", newLog)

On Error Resume Next
Err.Clear
CN.Execute SQL
If Err.Number <> 0 Then
    RestoreWithMoveOK = False
Else
    RestoreWithMoveOK = True
End If
   
End Function

Public Function RightPart(WholeString, FindString) As String

Dim pos As Long

pos = InStr(1, WholeString, FindString, vbTextCompare)
If pos = 0 Then
    RightPart = ""
ElseIf pos = Len(WholeString) Then
    RightPart = ""
Else
    RightPart = Mid$(WholeString, pos + Len(FindString))
End If

End Function

Public Function cSQLTime(TV As Date) As String

' Formats a time value for an SQL statement

cSQLTime = Format(TV, "HH:NN:SS")
End Function

Function DeleteTableOK(CN As ADODB.Connection, TableName As String, Optional CheckExists As Boolean = False) As Boolean

Dim SQL As String
Dim OK

SQL = "Drop Table [" + TableName + "]"
If CheckExists Then
    If TableExists(CN, TableName) Then
        DeleteTableOK = ExecuteSQLOK(CN, SQL)
    End If
Else
    DeleteTableOK = ExecuteSQLOK(CN, SQL)
End If


End Function

Public Sub Destroy(AnyRecordset As ADODB.Recordset)

' Close a recordset which may or may not be open
' Used at the end of a sub where not all
' recordsets declared may have been opened.

' ADO.Destroy RS


If Not IsNull(AnyRecordset) Then
    AnyRecordset.Close
    Set AnyRecordset = Nothing
End If

End Sub

Public Sub DestroyCN(AnyCN As ADODB.Connection)

' Close a connection which may or may not be open
' Used at the end of a sub where not all
' recordsets declared may have been opened.

' ADO.DestroyCN CN


If Not IsNull(AnyCN) Then
    AnyCN.Close
    Set AnyCN = Nothing
End If

End Sub
Function RenameTableOK(CN As ADODB.Connection, Oldname As String, NewName As String)

' Renames a SQL Server Table

Dim SQL As String
Dim OK

' TODO if DBTYPE="MDB" then  need to change for Access

SQL = "EXEC sp_rename '" + Oldname + "', '" + NewName + "'"

OK = ExecuteSQLOK(CN, SQL)

End Function
Function TableExists(CN As ADODB.Connection, TableName As String) As Boolean

Dim RS As ADODB.Recordset
On Error Resume Next
Set RS = CN.OpenSchema(adSchemaTables, Array(Empty, Empty, TableName, "TABLE"))
Do
    If Err.Number <> 0 Then
        TableExists = False
        Exit Do
    End If
    If RS.EOF Then
        TableExists = False
    Else
        TableExists = True
    End If
    RS.Close
    Exit Do
Loop

Set RS = Nothing

End Function



Sub TypeNames(RS As ADODB.Recordset, SQLFlags As Long, SQLSize As Long, rADOName As String, rDAOName As String, rFixedSize As Long, Fmat As String, DefaultValue As String)

' RS is an open schemaTables recordset.
' Returns data type info:
' SQLFlags  see schema tables for this info
' SQLSize   maximum size of a text field.
' rADOName e.g. Int
' rDAOName (provides a cross between the visual basic data type)
' FixedSize of the field.
' A suggested format
' DefaultValue of the field.

Dim SQLDataType As Long
Dim nscale As Long

SQLDataType = RS("DATA_TYPE")

rFixedSize = SQLSize
Select Case SQLDataType
    Case Is = 2
        rDAOName = "Integer"
        rADOName = "SmallInt"
        rFixedSize = 0
        Fmat = "0"
    Case Is = 3
        rDAOName = "Long"
        rADOName = "Int"
        rFixedSize = 0
        Fmat = "0"
    Case Is = 4
        rDAOName = "Single"
        rADOName = "Real"
        rFixedSize = 0
        Fmat = "0"
    Case Is = 5
        rDAOName = "Double"
        rADOName = "Float"
        rFixedSize = 0
        Fmat = "0"
    Case Is = 6
        rDAOName = "Currency"
        rADOName = "Money"
        rFixedSize = 0
        Fmat = "0"
    Case Is = 7
        rDAOName = "Date"
        rADOName = "Datetime"
        rFixedSize = 0
        Fmat = "DD-MMM-YY hh:nn:ss"
    Case Is = 11
        rDAOName = "Boolean"
        rADOName = "Bit"
        rFixedSize = 0
        Fmat = "True/False"
    Case Is = 17
        rDAOName = "Byte"
        rADOName = "TinyInt"
        rFixedSize = 0
        nscale = GitNum(RS("NUMERIC_SCALE"))
        Fmat = "0"
        If nscale > 0 Then
            Fmat = "0." + String(nscale, "0")
        End If
    Case Is = 129
        If SQLFlags And 128 Then
            rDAOName = "Memo"
            rADOName = "Text"
            rFixedSize = 0
            Fmat = ""
        ElseIf SQLFlags And 16 Then
            rADOName = "Char"
            rDAOName = "Text"
            Fmat = ""
        Else
            rADOName = "VarChar"
            rDAOName = "Text"
            If rFixedSize > 255 Then
                rDAOName = "Memo"
'            Stop
            End If
            Fmat = ""
        End If
    Case Is = 130
        If SQLFlags And 128 Then
            rDAOName = "Memo"
            If DBType = "MDB" Then
                rADOName = "text"
            Else
                rADOName = "ntext"
            End If
            rFixedSize = 0
            Fmat = ""
       ElseIf SQLFlags And 16 Then
            rADOName = "Char"
            rDAOName = "Text"
            Fmat = ""
        Else
            rADOName = "VarChar"
            rDAOName = "Text"
            Fmat = ""
            If rFixedSize > 255 Then
               
                rDAOName = "Memo"
            'Stop
            End If
        End If
    Case Is = 131
        rDAOName = "Double"
        rADOName = "Numeric"
        rFixedSize = 0
        nscale = GitNum(RS("NUMERIC_SCALE"))
        Fmat = "0"
        If nscale > 0 Then
            Fmat = "0." + String(nscale, "0")
        End If
    Case Is = 135
        rDAOName = "Date"
        rADOName = "Datetime"
        rFixedSize = 0
        Fmat = "DD-MMM-YY hh:nn:ss"
       
    Case Else
        rDAOName = "?Text"
        rADOName = "?varchar"
        Fmat = ""
End Select
   
   
End Sub

Public Function InsertGetCounter(CN As ADODB.Connection, SQLforInsertInto As String) As Long


' This function should return the value of a tbales indetity field after
' running an insert query

' I think that this won't work wtih an MDB and need the NOCount removing.

' CN Must be a valid connection
' SQLforInsertInto is the Insert saletement to be used.

Dim RS As ADODB.Recordset
Dim SQL$
   

If DBType <> "MDB" Then
    '===============
    ' ACCESS MDB
    On Error Resume Next
    Err.Clear
    Set RS = CN.Execute(SQL$)
    If Err.Number = 0 Then
        Set RS = CN.Execute("@@Idenity")
        If Err.Number = 0 Then
            InsertGetCounter = RS.Fields(0).Value
            RS.Close
        Else
            InsertGetCounter = 0
        End If
    End If
Else
    '=============
    ' SQL Server
    SQL$ = "SET NOCOUNT ON;" + SQLforInsertInto
    If Right$(SQL, 1) <> ";" Then
        SQL = SQL + ";"
    End If
    SQL$ = SQL$ + " Select @@Identity as RecID;SET NOCOUNT OFF;"
   
    On Error Resume Next
    Err.Clear
    Set RS = CN.Execute(SQL$)
    If Err.Number = 0 Then
        InsertGetCounter = RS("RecID")
        RS.Close
    Else
        InsertGetCounter = 0
    End If
End If
Set RS = Nothing

End Function

Public Function Git(dt)

' Use this function when accessing ALL record set fields
' To avoide ilegal use of Null error

If IsNull(dt) Then
    Git = ""
Else
    Git = dt
End If

End Function


Public Function GitNum(dt)

' Use this function when accessing ALL record set fields
' To avoide ilegal use of Null error

If IsNull(dt) Then
    GitNum = 0
Else
    GitNum = dt
End If

End Function


Public Function CopyTableOK(CN As ADODB.Connection, SourceDB As String, SourceTable As String, DestinationDB As String, DestinationTable As String) As Boolean

' Copies a Table
'ok = ADO.CopyTableOK(CN, "MySourceDB", "MyTable", "DestDB", "DestTable")

Dim SQL As String
Dim OK
Const owner As String = "DBO"



CopyTableOK = False

' Use the Destination
SQL = "USE " + DestinationDB + vbCrLf
SQL = SQL + "GO" + vbCrLf
On Error Resume Next
CN.Execute SQL$
If Err.Number <> 0 Then
    Exit Function
End If

SQL$ = "Drop Table [" + DestinationTable + "];"
On Error Resume Next
Err.Clear
CN.Execute SQL$
' Ignore the error as tbale may not exists

' Make sure bulk copy option is on.
SQL = ""
SQL$ = SQL$ + "EXEC sp_dboption '" + DestinationDB + "','select into/bulkcopy', 'True';"
On Error Resume Next
Err.Clear
CN.Execute SQL$
If Err.Number <> 0 Then
    Exit Function
End If

' Copy the table
SQL$ = "SELECT * INTO [" + DestinationTable + "] From [" + SourceDB + "].[" _
        + owner + "].[" + SourceTable + "];"
On Error Resume Next
Err.Clear
CN.Execute SQL$
If Err.Number <> 0 Then
    Exit Function
End If

' Make sure bulk copy option is on.
SQL = ""
SQL$ = SQL$ + "EXEC sp_dboption '" + DestinationDB + "','select into/bulkcopy', 'True';"
On Error Resume Next
Err.Clear
CN.Execute SQL$
If Err.Number <> 0 Then
    Exit Function
End If

CopyTableOK = OK

End Function

Public Function GetLastError(CN As ADODB.Connection) As String

' Returns the last error on a connection

'Example:
' OK = ADO.ConnectOK(CN)
' If Not OK Then
'      MsgBox ADO.GetLastError(CN)

If CN Is Nothing Then
    GetLastError = "Connection is invalid"
    Exit Function
End If

Dim m$

Dim E As ADODB.Error
Dim Elist As ADODB.Errors
Set Elist = CN.Errors
For Each E In Elist
    m$ = m$ + CStr(E.Number) + " " + E.Description + " " + E.Source + " " + E.SQLState + vbCrLf
Next
   
GetLastError = m$

End Function
Public Function cSQL(ByRef SQLData As String) As String

cSQL = Replace(SQLData, "'", "''")

End Function


Function cSQLDate(DatePassed As Date)

' converts a string for use in an SQL

'example:
'strWhere = "MyDate = '" + ADO.cSQLDate(Now) + "'"


If Len(mCurrentDateFormat) = 0 Then
    mCurrentDateFormat = "YYYY-MM-DD HH:Nn:SS"
End If

cSQLDate = Format$(DatePassed, mCurrentDateFormat)

End Function
Function GetADOCounter(CN As Connection) As Long
' Returns a tables identity after an insert into
' SQL="Insert Into Fred (Field1, Field2) Values (10,20)"
' OK=ADO.
' OK=ADO.ExecureSQLOK(CN, SQL)
' NewRecord = ADO.GetADOCounter(CN)

' warning won't work for table triggers

Dim stRSQL$
Dim rsNewAutoIncrement As ADODB.Recordset

stRSQL = "SELECT @@Identity"
   
Set rsNewAutoIncrement = New ADODB.Recordset
On Error Resume Next
Err.Clear
rsNewAutoIncrement.Open stRSQL, CN, adOpenForwardOnly, _
                        adLockReadOnly, adCmdText
GetADOCounter = rsNewAutoIncrement.Fields(0).Value
If Err.Number <> 0 Then
    GetADOCounter = 0
End If
rsNewAutoIncrement.Close

End Function

Public Function ExecuteSQLOK(CN As ADODB.Connection, SQL$, Optional BeginCommit As Boolean = False) As Boolean

' Execute an SQL statement
On Error Resume Next
If BeginCommit Then CN.BeginTrans
CN.Execute SQL, , adCmdText + adExecuteNoRecords

If CommandLogging Then
    Commands = Commands + SQL + vbCrLf + "GO" + vbCrLf
End If

If BeginCommit Then CN.CommitTrans

If Err.Number <> 0 Then
    If BeginCommit Then
        CN.RollbackTrans
    End If
    ExecuteSQLOK = False
    Commands = Commands + "/* Failed" + vbCrLf
Else
    ExecuteSQLOK = True
End If

End Function



Public Function ExecuteRSSQLOK(CN As ADODB.Connection, RS As ADODB.Recordset, SQL$) As Boolean

' Execute an SQL statement
Dim ra As Long

ExecuteRSSQLOK = False
On Error Resume Next
Set RS = CN.Execute(SQL) ', ra)

If Err.Number <> 0 Then
    ExecuteRSSQLOK = False
Else
    ExecuteRSSQLOK = True
End If

End Function



Public Function ConnectOK(CN As ADODB.Connection) As Boolean
ConnectOK = ConnectODBCOK(CN, ConnectionString)
End Function


Public Function IDE() As Boolean

' Returns True if running in debug (IDE) mode
'         False if running in an EXE

'Example:
' If ADO.IDE Then Stop

If Not mIDEDone Then ' See below
'To make this function work you need the following in your
' class declarations:
'Dim mIDEDone As Boolean
'Dim mIDE As Boolean

    ' just do this first time round then store the result
    On Error Resume Next
    Err.Clear
    Debug.Print 1 / 0
    If Err.Number <> 0 Then
        mIDE = True
    Else
        mIDE = False
    End If
    mIDEDone = True
End If
IDE = mIDE
End Function


Public Function ConnectODBCOK(CN As ADODB.Connection, ODBCString As String) As Boolean

' Open a connection
' return OK status = True or False
   

Set CN = New ADODB.Connection
On Error Resume Next
Err = 0
CN.ConnectionString = ODBCString
CN.CommandTimeout = 1200
CN.ConnectionTimeout = 45
CN.Open
If Err.Number <> 0 Then
    ConnectODBCOK = False
Else
    ConnectODBCOK = True
End If

DBTypeFound = False
MDBName = ""

mCN = CStr(CN) ' save connection info

' Here is where you need to find the database format if you are not using English (USA) user
' and set mCurrentDateFormat
' Normally this value is mCurrentDateFormat

End Function







Public Sub RegisterConnectString(ADOConnectionString As String)

' Register a connection string
' like:
' "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\DATA\TEMP\TEST.MDB;"
' "driver=SQL Server;server=server4;uid=userid;pwd=password;database=databasename;"

' See Examples for usage

ConnectionString = ADOConnectionString

End Sub


Public Function OpenRSROOK(CN As ADODB.Connection, RS As ADODB.Recordset, SQL As String) As Boolean

' Open Recordset Readonly returns status true=wroked false = failed

Set RS = New ADODB.Recordset

On Error Resume Next
Err.Clear

RS.Open SQL$, CN, adOpenStatic, adLockReadOnly

If Err.Number <> 0 Then
    OpenRSROOK = False
    Set RS = Nothing
Else
    OpenRSROOK = True
End If

End Function


Public Function OpenRSUpdateOK(CN As ADODB.Connection, RS As ADODB.Recordset, SQL$) As Boolean

' Open Recordset for updating

Set RS = New ADODB.Recordset

On Error Resume Next
Err.Clear

RS.CursorLocation = adUseServer

RS.Open SQL$, CN, adOpenKeyset, adLockOptimistic

If Err.Number <> 0 Then
    OpenRSUpdateOK = False
    Set RS = Nothing
Else
    OpenRSUpdateOK = True
End If

End Function
' Don't forget to Add projet reference to MS ActiveX Data Objects
Public Function OpenRSOK(CN As ADODB.Connection, RS As ADODB.Recordset, SQL$, Optional CursorType As ADODB.CursorTypeEnum = adOpenForwardOnly, Optional LockType As LockTypeEnum = adLockReadOnly, Optional CommandType As ADODB.CommandTypeEnum = adCmdText, Optional CursorLocation As ADODB.CursorLocationEnum = adUseServer) As Boolean

' Opens any type of recoordset return true is OK

Set RS = New ADODB.Recordset

On Error Resume Next
Err.Clear

RS.CursorLocation = CursorLocation

RS.Open SQL$, CN, CursorType, LockType, CommandType

If Err.Number <> 0 Then
    Set RS = Nothing
    OpenRSOK = False
Else
    OpenRSOK = True
End If

End Function


Function FindOK(RS As ADODB.Recordset, Condition As String) As Boolean

' Incase you need more complex stuff
    ' Direction constants.
    '   adSearchBackward
    '   adSearchForward
    ' Start Point
    '   adBookmarkCurrent
    '   adBookmarkFirst
    '   adBookmarkLast

' Finds a record
' see: http://www.devguru.com/Technologies/ado/quickref/recordset_find.html

If Not RS.BOF Then
    RS.MoveFirst
End If

RS.Find Contition, , adSearchForward

If (RS.BOF) Or (RS.EOF) Then
    FindOK = False
Else
    FindOK = True
End If

End Function


0
 
LVL 17

Expert Comment

by:inthedark
ID: 7019368
Soory for typos

b) Use find sed function FindOK

should say

b) Use the recordset.Find (see the function ADO.FindOK)
0
 

Author Comment

by:ashraf_t
ID: 7019603
thanx a lot
0

Featured Post

Why You Should Analyze Threat Actor TTPs

After years of analyzing threat actor behavior, it’s become clear that at any given time there are specific tactics, techniques, and procedures (TTPs) that are particularly prevalent. By analyzing and understanding these TTPs, you can dramatically enhance your security program.

Join & Write a Comment

This article describes some techniques which will make your VBA or Visual Basic Classic code easier to understand and maintain, whether by you, your replacement, or another Experts-Exchange expert.
You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

760 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now