Excel - ACCESS - Excel!

In the following examples a data base (ACCESS mdb) is provided. Then a table and several columns are provided. Subsequently, data are provided, changed, deleted and exchanged. Explanation and structure in the example files. Importantly - pay attention to reference! The files at the end of the article are Excelfiles of the version 2003 and 2007.


The following code belonged In "Module1"

Option Explicit
'Clicking on Tools, then References.
'Inside of this window, you'd enable
'Microsoft ActiveX Data Objects X.X Library
'and
'Microsoft ADO Ext. X.X for DLL and Security
Private Declare Function ShellExecute Lib "Shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Public Declare Function SetForegroundWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Const SW_MAXIMIZE = 3
Public Sub DataBase_1()
Dim strFileName As String
Dim objDataBase As Object
On Error GoTo Fin
strFileName = ThisWorkbook.Path & "\Test.mdb"
If Dir(strFileName) <> "" Then Kill (strFileName)
Set objDataBase = CreateObject("ADOX.Catalog")
objDataBase.Create "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=" & strFileName
Set objDataBase = Nothing
ShellExecute Application.hwnd, "Open", strFileName, _
"", "", SW_MAXIMIZE
SetForegroundWindow (Application.hwnd)
Application.WindowState = xlMaximized
On Error GoTo 0
Exit Sub
Fin:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Set objDataBase = Nothing
End Sub

The following code belonged In "Module2"

Option Explicit
Private Declare Function ShellExecute Lib "Shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Public Declare Function SetForegroundWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Const SW_MAXIMIZE = 3
Public Sub DataBase_2()
Dim objConn As ADODB.Connection
Dim strFileName As String
Dim strSQL As String
On Error GoTo Fin
If ACC_Active Then
MsgBox "Please close all ACCESS instances!"
Exit Sub
End If
strFileName = ThisWorkbook.Path & "\Test.mdb"
If Dir(strFileName) = "" Then
MsgBox "Data base does not exist!"
Exit Sub
End If
Set objConn = New ADODB.Connection
With objConn
.CursorLocation = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Data Source") = strFileName
.Open
End With
strSQL = "CREATE TABLE Name (ID COUNTER NOT NULL " & _
"CONSTRAINT DB_ID PRIMARY KEY, " & _
"FirstName TEXT(20) NOT NULL, " & _
"Surname TEXT(30) NOT NULL, " & _
"Birthday DATE, " & _
"Address TEXT(60), " & _
"PostalZipCode LONG DEFAULT 11427, " & _
"City TEXT(60))"
objConn.Execute strSQL
objConn.Close
Set objConn = Nothing
ShellExecute Application.hwnd, "Open", strFileName, _
"", "", SW_MAXIMIZE
SetForegroundWindow (Application.hwnd)
Application.WindowState = xlMaximized
On Error GoTo 0
Exit Sub
Fin:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Set objConn = Nothing
End Sub
Private Function ACC_Active() As Boolean
Dim ACCApp As Object
On Error Resume Next
Set ACCApp = GetObject(, "Access.Application")
If Err.Number = 429 Then
ACC_Active = False
Else
ACC_Active = True
End If
End Function

The following code belonged In "Module3"

Option Explicit
Private Declare Function ShellExecute Lib "Shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Public Declare Function SetForegroundWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Const SW_MAXIMIZE = 3
Public Sub DataBase_3()
Dim objConn As ADODB.Connection
Dim strFileName As String
Dim strSQL As String
On Error GoTo Fin
If ACC_Active Then
MsgBox "Please close all ACCESS instances!"
Exit Sub
End If
strFileName = ThisWorkbook.Path & "\Test.mdb"
If Dir(strFileName) = "" Then
MsgBox "Data base does not exist!"
Exit Sub
End If
Set objConn = New ADODB.Connection
With objConn
.CursorLocation = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Data Source") = strFileName
.Open
End With
strSQL = "DROP TABLE Name"
objConn.Execute strSQL
objConn.Close
Set objConn = Nothing
ShellExecute Application.hwnd, "Open", strFileName, _
"", "", SW_MAXIMIZE
SetForegroundWindow (Application.hwnd)
Application.WindowState = xlMaximized
On Error GoTo 0
Exit Sub
Fin:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Set objConn = Nothing
End Sub
Private Function ACC_Active() As Boolean
Dim ACCApp As Object
On Error Resume Next
Set ACCApp = GetObject(, "Access.Application")
If Err.Number = 429 Then
ACC_Active = False
Else
ACC_Active = True
End If
End Function

The following code belonged In "Module4"

Option Explicit
Private Declare Function ShellExecute Lib "Shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Public Declare Function SetForegroundWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Const SW_MAXIMIZE = 3
Public Sub DataBase_4()
Dim objConn As ADODB.Connection
Dim strFileName As String
Dim strSQL As String
On Error GoTo Fin
If ACC_Active Then
MsgBox "Please close all ACCESS instances!"
Exit Sub
End If
strFileName = ThisWorkbook.Path & "\Test.mdb"
If Dir(strFileName) = "" Then
MsgBox "Data base does not exist!"
Exit Sub
End If
Set objConn = New ADODB.Connection
With objConn
.CursorLocation = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Data Source") = strFileName
.Open
End With
strSQL = "ALTER TABLE Name ADD COLUMN Telephone TEXT(20)"
objConn.Execute strSQL
objConn.Close
Set objConn = Nothing
ShellExecute Application.hwnd, "Open", strFileName, _
"", "", SW_MAXIMIZE
SetForegroundWindow (Application.hwnd)
Application.WindowState = xlMaximized
On Error GoTo 0
Exit Sub
Fin:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Set objConn = Nothing
End Sub
Private Function ACC_Active() As Boolean
Dim ACCApp As Object
On Error Resume Next
Set ACCApp = GetObject(, "Access.Application")
If Err.Number = 429 Then
ACC_Active = False
Else
ACC_Active = True
End If
End Function

The following code belonged In "Module5"

Option Explicit
Private Declare Function ShellExecute Lib "Shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Public Declare Function SetForegroundWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Const SW_MAXIMIZE = 3
Public Sub DataBase_5()
Dim rcsEntry As New ADODB.Recordset
Dim catCatalog As New ADOX.Catalog
Dim objConn As ADODB.Connection
Dim strSheetName As String
Dim strFileName As String
Dim blnTMP As Boolean
Dim intNumber As Integer
Dim strSQL As String
On Error GoTo Fin
If ACC_Active Then
MsgBox "Please close all ACCESS instances!"
Exit Sub
End If
strFileName = ThisWorkbook.Path & "\Test.mdb"
If Dir(strFileName) = "" Then
MsgBox "Data base does not exist!"
Exit Sub
End If
Set rcsEntry = New ADODB.Recordset
Set objConn = New ADODB.Connection
With objConn
.CursorLocation = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Data Source") = strFileName
.Open
End With
Set catCatalog.ActiveConnection = objConn
On Error Resume Next
Err.Clear
strSheetName = catCatalog.Tables("Name").Name
blnTMP = (Err = 0)
On Error GoTo 0
If Not blnTMP Then
MsgBox "Table ""Name"" missing!"
objConn.Close
Set rcsEntry = Nothing
Set objConn = Nothing
Exit Sub
Else
With rcsEntry
.ActiveConnection = objConn
.CursorLocation = adUseClient
.Source = "SELECT * FROM " & "Name"
.Open
For intNumber = 1 To .Fields.Count - 1
If .Fields(intNumber).Name = "Remark" Then
MsgBox "Column already available!"
Set rcsEntry = Nothing
Set objConn = Nothing
Exit Sub
End If
Next intNumber
End With
strSQL = "ALTER TABLE Name ADD COLUMN Remark TEXT(40)"
objConn.Execute strSQL
rcsEntry.Close
objConn.Close
Set rcsEntry = Nothing
Set objConn = Nothing
ShellExecute Application.hwnd, "Open", strFileName, _
"", "", SW_MAXIMIZE
SetForegroundWindow (Application.hwnd)
Application.WindowState = xlMaximized
End If
On Error GoTo 0
Exit Sub
Fin:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Set rcsEntry = Nothing
Set objConn = Nothing
End Sub
Public Sub Column_delete()
Dim objConn As ADODB.Connection
Dim strFileName As String
Dim strSQL As String
On Error GoTo Spalte_loeschen_Error
strFileName = ThisWorkbook.Path & "\Test.mdb"
Set objConn = New ADODB.Connection
With objConn
.CursorLocation = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Data Source") = strFileName
.Open
End With
strSQL = "ALTER TABLE Name DROP COLUMN Telephone"
objConn.Execute strSQL
objConn.Close
Set objConn = Nothing
ShellExecute Application.hwnd, "Open", strFileName, _
"", "", SW_MAXIMIZE
SetForegroundWindow (Application.hwnd)
Application.WindowState = xlMaximized
On Error GoTo 0
Exit Sub
Spalte_loeschen_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
End Sub
Public Sub Column_type_change()
Dim objConn As ADODB.Connection
Dim strFileName As String
Dim strSQL As String
On Error GoTo Spalte_Typ_aendern_Error
strFileName = ThisWorkbook.Path & "\Test.mdb"
Set objConn = New ADODB.Connection
With objConn
.CursorLocation = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Data Source") = strFileName
.Open
End With
strSQL = "ALTER TABLE Name ALTER COLUMN Remark VARCHAR(100)"
objConn.Execute strSQL
objConn.Close
Set objConn = Nothing
ShellExecute Application.hwnd, "Open", strFileName, "", "", SW_MAXIMIZE
SetForegroundWindow (Application.hwnd)
Application.WindowState = xlMaximized
On Error GoTo 0
Exit Sub
Spalte_Typ_aendern_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
End Sub
Private Function ACC_Active() As Boolean
Dim ACCApp As Object
On Error Resume Next
Set ACCApp = GetObject(, "Access.Application")
If Err.Number = 429 Then
ACC_Active = False
Else
ACC_Active = True
End If
End Function

The following code belonged In "Module6"

Option Explicit
Private Declare Function ShellExecute Lib "Shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Public Declare Function SetForegroundWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Const SW_MAXIMIZE = 3
Public Sub DataBase_6()
Dim rcsEntry As New ADODB.Recordset
Dim catCatalog As New ADOX.Catalog
Dim objConn As ADODB.Connection
Dim strSheetName As String
Dim strFileName As String
Dim wksSheet As Worksheet
Dim blnTMP As Boolean
Dim intNumber As Integer
On Error GoTo Fin
If ACC_Active Then
MsgBox "Please close all ACCESS instances!"
Exit Sub
End If
Set wksSheet = Sheet2
strFileName = ThisWorkbook.Path & "\Test.mdb"
If Dir(strFileName) = "" Then
MsgBox "Data base does not exist!"
Exit Sub
End If
Set rcsEntry = New ADODB.Recordset
Set objConn = New ADODB.Connection
With objConn
.CursorLocation = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Data Source") = strFileName
.Open
End With
Set catCatalog.ActiveConnection = objConn
On Error Resume Next
Err.Clear
strSheetName = catCatalog.Tables("Name").Name
blnTMP = (Err = 0)
On Error GoTo 0
If Not blnTMP Then
MsgBox "Table ""Name"" missing!"
objConn.Close
Set rcsEntry = Nothing
Set wksSheet = Nothing
Set objConn = Nothing
Exit Sub
Else
With rcsEntry
.ActiveConnection = objConn
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.CursorType = adOpenKeyset
.Source = "SELECT * FROM " & "Name"
.Open
For intNumber = 2 To wksSheet.UsedRange.Rows.Count
.AddNew
.Fields("FirstName") = _
wksSheet.Cells(intNumber, 1)
.Fields("Surname") = _
wksSheet.Cells(intNumber, 2)
.Fields("Birthday") = _
wksSheet.Cells(intNumber, 3)
.Fields("Address") = _
wksSheet.Cells(intNumber, 4)
.Fields("PostalZipCode") = _
wksSheet.Cells(intNumber, 5)
.Fields("City") = _
wksSheet.Cells(intNumber, 6)
.Update
Next intNumber
End With
rcsEntry.Close
objConn.Close
Set rcsEntry = Nothing
Set wksSheet = Nothing
Set objConn = Nothing
ShellExecute Application.hwnd, "Open", strFileName, _
"", "", SW_MAXIMIZE
SetForegroundWindow (Application.hwnd)
Application.WindowState = xlMaximized
End If
On Error GoTo 0
Exit Sub
Fin:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Set rcsEntry = Nothing
Set wksSheet = Nothing
Set objConn = Nothing
End Sub
Private Function ACC_Active() As Boolean
Dim ACCApp As Object
On Error Resume Next
Set ACCApp = GetObject(, "Access.Application")
If Err.Number = 429 Then
ACC_Active = False
Else
ACC_Active = True
End If
End Function

The following code belonged In "Module7"

Option Explicit
Private Declare Function ShellExecute Lib "Shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Public Declare Function SetForegroundWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Const SW_MAXIMIZE = 3
Public Sub DataBase_7()
Dim rcsEntry As New ADODB.Recordset
Dim catCatalog As New ADOX.Catalog
Dim objConn As ADODB.Connection
Dim strSheetName As String
Dim strFileName As String
Dim strDelete As String
Dim blnTMP As Boolean
On Error GoTo Fin
If ACC_Active Then
MsgBox "Please close all ACCESS instances!"
Exit Sub
End If
strFileName = ThisWorkbook.Path & "\Test.mdb"
If Dir(strFileName) = "" Then
MsgBox "Data base does not exist!"
Exit Sub
End If
strDelete = Application.InputBox("Data record delete", _
"Delete!", "12345", , , , , 2)
If strDelete = "" Then Exit Sub
Set rcsEntry = New ADODB.Recordset
Set objConn = New ADODB.Connection
With objConn
.CursorLocation = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Data Source") = strFileName
.Open
End With
Set catCatalog.ActiveConnection = objConn
On Error Resume Next
Err.Clear
strSheetName = catCatalog.Tables("Name").Name
blnTMP = (Err = 0)
On Error GoTo 0
If Not blnTMP Then
MsgBox "Table ""Name"" missing!"
objConn.Close
Set rcsEntry = Nothing
Set objConn = Nothing
Exit Sub
Else
With rcsEntry
.ActiveConnection = objConn
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.CursorType = adOpenKeyset
.Source = "SELECT * FROM " & "Name"
.Open
.MoveFirst
.Find "PostalZipCode = " & "'" & strDelete & "'"
If Not .EOF Then
.Delete
.MoveFirst
End If
End With
rcsEntry.Close
objConn.Close
Set rcsEntry = Nothing
Set objConn = Nothing
ShellExecute Application.hwnd, "Open", strFileName, _
"", "", SW_MAXIMIZE
SetForegroundWindow (Application.hwnd)
Application.WindowState = xlMaximized
End If
On Error GoTo 0
Exit Sub
Fin:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Set rcsEntry = Nothing
Set objConn = Nothing
End Sub
Private Function ACC_Active() As Boolean
Dim ACCApp As Object
On Error Resume Next
Set ACCApp = GetObject(, "Access.Application")
If Err.Number = 429 Then
ACC_Active = False
Else
ACC_Active = True
End If
End Function

The following code belonged In "Module8"

Option Explicit
Private Declare Function ShellExecute Lib "Shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Public Declare Function SetForegroundWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Const SW_MAXIMIZE = 3
Public Sub DataBase_8()
Dim rcsEntry As New ADODB.Recordset
Dim catCatalog As New ADOX.Catalog
Dim objConn As ADODB.Connection
Dim strSheetName As String
Dim strFileName As String
Dim strDelete As String
Dim blnTMP As Boolean
Dim intNumber As Integer
On Error GoTo Fin
If ACC_Active Then
MsgBox "Please close all ACCESS instances!"
Exit Sub
End If
strFileName = ThisWorkbook.Path & "\Test.mdb"
If Dir(strFileName) = "" Then
MsgBox "Data base does not exist!"
Exit Sub
End If
strDelete = Application.InputBox("Data record delete", _
"Delete!", "12345", , , , , 2)
If strDelete = "" Then Exit Sub
Set rcsEntry = New ADODB.Recordset
Set objConn = New ADODB.Connection
With objConn
.CursorLocation = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Data Source") = strFileName
.Open
End With
Set catCatalog.ActiveConnection = objConn
On Error Resume Next
Err.Clear
strSheetName = catCatalog.Tables("Name").Name
blnTMP = (Err = 0)
On Error GoTo 0
If Not blnTMP Then
MsgBox "Table ""Name"" missing!"
objConn.Close
Set rcsEntry = Nothing
Set objConn = Nothing
Exit Sub
Else
With rcsEntry
.ActiveConnection = objConn
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.CursorType = adOpenKeyset
.Source = "SELECT * FROM " & "Name"
.Open
.MoveFirst
.Filter = "PostalZipCode = " & "'" & strDelete & "'"
For intNumber = 0 To .RecordCount - 1
If Not .EOF Then
.Delete
.MoveFirst
End If
Next intNumber
End With
rcsEntry.Close
objConn.Close
Set rcsEntry = Nothing
Set objConn = Nothing
ShellExecute Application.hwnd, "Open", strFileName, _
"", "", SW_MAXIMIZE
SetForegroundWindow (Application.hwnd)
Application.WindowState = xlMaximized
End If
On Error GoTo 0
Exit Sub
Fin:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Set rcsEntry = Nothing
Set objConn = Nothing
End Sub
Private Function ACC_Active() As Boolean
Dim ACCApp As Object
On Error Resume Next
Set ACCApp = GetObject(, "Access.Application")
If Err.Number = 429 Then
ACC_Active = False
Else
ACC_Active = True
End If
End Function

The following code belonged In "Module9"

Option Explicit
Private Declare Function ShellExecute Lib "Shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Public Declare Function SetForegroundWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Const SW_MAXIMIZE = 3
Public Sub DataBase_9()
Dim rcsEntry As New ADODB.Recordset
Dim catCatalog As New ADOX.Catalog
Dim objConn As ADODB.Connection
Dim strSheetName As String
Dim strFileName As String
Dim blnTMP As Boolean
Dim strAlt As String
Dim strNeu As String
On Error GoTo Fin
If ACC_Active Then
MsgBox "Please close all ACCESS instances!"
Exit Sub
End If
strFileName = ThisWorkbook.Path & "\Test.mdb"
If Dir(strFileName) = "" Then
MsgBox "Data base does not exist!"
Exit Sub
End If
strAlt = Application.InputBox("Postal code change?", _
"Change!", "54321", , , , , 2)
If strAlt = "" Then Exit Sub
strNeu = Application.InputBox("New postal code!", _
"Change!", "99999", , , , , 2)
If strNeu = "" Then Exit Sub
Set rcsEntry = New ADODB.Recordset
Set objConn = New ADODB.Connection
With objConn
.CursorLocation = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Data Source") = strFileName
.Open
End With
Set catCatalog.ActiveConnection = objConn
On Error Resume Next
Err.Clear
strSheetName = catCatalog.Tables("Name").Name
blnTMP = (Err = 0)
On Error GoTo 0
If Not blnTMP Then
MsgBox "Table ""Name"" missing!"
objConn.Close
Set rcsEntry = Nothing
Set objConn = Nothing
Exit Sub
Else
With rcsEntry
.ActiveConnection = objConn
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.CursorType = adOpenKeyset
.Source = "SELECT * FROM " & "Name"
.Open
.MoveFirst
.Find "PostalZipCode = " & "'" & strAlt & "'"
.Fields("PostalZipCode") = strNeu
.Update
End With
rcsEntry.Close
objConn.Close
Set rcsEntry = Nothing
Set objConn = Nothing
ShellExecute Application.hwnd, "Open", strFileName, _
"", "", SW_MAXIMIZE
SetForegroundWindow (Application.hwnd)
Application.WindowState = xlMaximized
End If
On Error GoTo 0
Exit Sub
Fin:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Set rcsEntry = Nothing
Set objConn = Nothing
End Sub
Private Function ACC_Active() As Boolean
Dim ACCApp As Object
On Error Resume Next
Set ACCApp = GetObject(, "Access.Application")
If Err.Number = 429 Then
ACC_Active = False
Else
ACC_Active = True
End If
End Function

The following code belonged In "Module10"

Option Explicit
Private Declare Function ShellExecute Lib "Shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Public Declare Function SetForegroundWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Const SW_MAXIMIZE = 3
Public Sub DataBase_10()
Dim rcsEntry As New ADODB.Recordset
Dim catCatalog As New ADOX.Catalog
Dim objConn As ADODB.Connection
Dim strSheetName As String
Dim strFileName As String
Dim blnTMP As Boolean
Dim intNumber As Integer
Dim strAlt As String
Dim strNeu As String
On Error GoTo Fin
If ACC_Active Then
MsgBox "Please close all ACCESS instances!"
Exit Sub
End If
strFileName = ThisWorkbook.Path & "\Test.mdb"
If Dir(strFileName) = "" Then
MsgBox "Data base does not exist!"
Exit Sub
End If
strAlt = Application.InputBox("Postal code change?", _
"Change!", "54321", , , , , 2)
If strAlt = "" Then Exit Sub
strNeu = Application.InputBox("New postal code!", _
"Change!", "99999", , , , , 2)
If strNeu = "" Then Exit Sub
Set rcsEntry = New ADODB.Recordset
Set objConn = New ADODB.Connection
With objConn
.CursorLocation = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Data Source") = strFileName
.Open
End With
Set catCatalog.ActiveConnection = objConn
On Error Resume Next
Err.Clear
strSheetName = catCatalog.Tables("Name").Name
blnTMP = (Err = 0)
On Error GoTo 0
If Not blnTMP Then
MsgBox "Table ""Name"" missing!"
objConn.Close
Set rcsEntry = Nothing
Set objConn = Nothing
Exit Sub
Else
With rcsEntry
.ActiveConnection = objConn
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.CursorType = adOpenKeyset
.Source = "SELECT * FROM " & "Name"
.Open
.MoveFirst
.Filter = "PostalZipCode = " & "'" & strAlt & "'"
For intNumber = 0 To .RecordCount - 1
If Not .EOF Then
.Fields("PostalZipCode") = strNeu
.MoveNext
End If
Next intNumber
End With
rcsEntry.Close
objConn.Close
Set rcsEntry = Nothing
Set objConn = Nothing
ShellExecute Application.hwnd, "Open", strFileName, _
"", "", SW_MAXIMIZE
SetForegroundWindow (Application.hwnd)
Application.WindowState = xlMaximized
End If
On Error GoTo 0
Exit Sub
Fin:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Set rcsEntry = Nothing
Set objConn = Nothing
End Sub
Private Function ACC_Active() As Boolean
Dim ACCApp As Object
On Error Resume Next
Set ACCApp = GetObject(, "Access.Application")
If Err.Number = 429 Then
ACC_Active = False
Else
ACC_Active = True
End If
End Function

The following code belonged In "Module11"

Option Explicit
Public Sub DataBase_11()
Dim rcsEntry As New ADODB.Recordset
Dim catCatalog As New ADOX.Catalog
Dim objConn As ADODB.Connection
Dim strSheetName As String
Dim strFileName As String
Dim wksSheet As Worksheet
Dim blnTMP As Boolean
Dim intNumber As Integer
On Error GoTo Fin
If ACC_Active Then
MsgBox "Please close all ACCESS instances!"
Exit Sub
End If
strFileName = ThisWorkbook.Path & "\Test.mdb"
Set wksSheet = Sheet3
wksSheet.Cells.Clear
If Dir(strFileName) = "" Then
MsgBox "Data base does not exist!"
Exit Sub
End If
Set rcsEntry = New ADODB.Recordset
Set objConn = New ADODB.Connection
With objConn
.CursorLocation = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Data Source") = strFileName
.Open
End With
Set catCatalog.ActiveConnection = objConn
On Error Resume Next
Err.Clear
strSheetName = catCatalog.Tables("Name").Name
blnTMP = (Err = 0)
On Error GoTo 0
If Not blnTMP Then
MsgBox "Table ""Name"" missing!"
objConn.Close
Set rcsEntry = Nothing
Set objConn = Nothing
Exit Sub
Else
With rcsEntry
.ActiveConnection = objConn
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.CursorType = adOpenKeyset
.Source = "SELECT * FROM " & "Name"
.Open
.MoveFirst
For intNumber = 0 To rcsEntry.Fields.Count - 1
wksSheet.Cells(1, 1).Offset(0, intNumber).Value = _
rcsEntry.Fields(intNumber).Name
wksSheet.Cells(1, 1).Offset _
(0, intNumber).Font.Bold = True
Next
wksSheet.Cells(1, 1).Offset(1, 0) _
.CopyFromRecordset rcsEntry
wksSheet.Columns("A:IV").AutoFit
End With
rcsEntry.Close
objConn.Close
Set rcsEntry = Nothing
Set objConn = Nothing
MsgBox "All values from ""Test.mdb"" in sheet3!"
End If
On Error GoTo 0
Exit Sub
Fin:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Set rcsEntry = Nothing
Set objConn = Nothing
End Sub
Private Function ACC_Active() As Boolean
Dim ACCApp As Object
On Error Resume Next
Set ACCApp = GetObject(, "Access.Application")
If Err.Number = 429 Then
ACC_Active = False
Else
ACC_Active = True
End If
End Function

The following code belonged In "Module12"

Option Explicit
Public Sub DataBase_12()
Dim rcsEntry As New ADODB.Recordset
Dim catCatalog As New ADOX.Catalog
Dim objConn As ADODB.Connection
Dim strSheetName As String
Dim strFileName As String
Dim wksSheet As Worksheet
Dim blnTMP As Boolean
Dim intNumber As Integer
On Error GoTo Fin
If ACC_Active Then
MsgBox "Please close all ACCESS instances!"
Exit Sub
End If
strFileName = ThisWorkbook.Path & "\Test.mdb"
Set wksSheet = Sheet3
wksSheet.Cells.Clear
If Dir(strFileName) = "" Then
MsgBox "Data base does not exist!"
Exit Sub
End If
Set rcsEntry = New ADODB.Recordset
Set objConn = New ADODB.Connection
With objConn
.CursorLocation = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Data Source") = strFileName
.Open
End With
Set catCatalog.ActiveConnection = objConn
On Error Resume Next
Err.Clear
strSheetName = catCatalog.Tables("Name").Name
blnTMP = (Err = 0)
On Error GoTo 0
If Not blnTMP Then
MsgBox "Table ""Name"" missing!"
objConn.Close
Set rcsEntry = Nothing
Set objConn = Nothing
Exit Sub
Else
With rcsEntry
.ActiveConnection = objConn
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.CursorType = adOpenKeyset
.Source = "SELECT FirstName FROM " & "Name"
.Open
.MoveFirst
For intNumber = 0 To rcsEntry.Fields.Count - 1
wksSheet.Cells(1, 1).Offset(0, intNumber).Value = _
rcsEntry.Fields(intNumber).Name
wksSheet.Cells(1, 1).Offset _
(0, intNumber).Font.Bold = True
Next
wksSheet.Cells(1, 1).Offset(1, 0). _
CopyFromRecordset rcsEntry
wksSheet.Columns("A:IV").AutoFit
End With
rcsEntry.Close
objConn.Close
Set rcsEntry = Nothing
Set objConn = Nothing
MsgBox "All First names from ""Test.mdb"" in sheet3!"
End If
On Error GoTo 0
Exit Sub
Fin:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Set rcsEntry = Nothing
Set objConn = Nothing
End Sub
Private Function ACC_Active() As Boolean
Dim ACCApp As Object
On Error Resume Next
Set ACCApp = GetObject(, "Access.Application")
If Err.Number = 429 Then
ACC_Active = False
Else
ACC_Active = True
End If
End Function

The following code belonged In "Module13"

Option Explicit
Public Sub DataBase_13()
Dim rcsEntry As New ADODB.Recordset
Dim catCatalog As New ADOX.Catalog
Dim objConn As ADODB.Connection
Dim strSheetName As String
Dim strFileName As String
Dim wksSheet As Worksheet
Dim blnTMP As Boolean
Dim intNumber As Integer
On Error GoTo Fin
If ACC_Active Then
MsgBox "Please close all ACCESS instances!"
Exit Sub
End If
strFileName = ThisWorkbook.Path & "\Test.mdb"
Set wksSheet = Sheet3
wksSheet.Cells.Clear
If Dir(strFileName) = "" Then
MsgBox "Data base does not exist!"
Exit Sub
End If
Set rcsEntry = New ADODB.Recordset
Set objConn = New ADODB.Connection
With objConn
.CursorLocation = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Data Source") = strFileName
.Open
End With
Set catCatalog.ActiveConnection = objConn
On Error Resume Next
Err.Clear
strSheetName = catCatalog.Tables("Name").Name
blnTMP = (Err = 0)
On Error GoTo 0
If Not blnTMP Then
MsgBox "Table ""Name"" missing!"
objConn.Close
Set rcsEntry = Nothing
Set objConn = Nothing
Exit Sub
Else
With rcsEntry
.ActiveConnection = objConn
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.CursorType = adOpenKeyset
.Source = "SELECT City FROM " & "Name" & _
" WHERE City='London'"
.Open
.MoveFirst
For intNumber = 0 To rcsEntry.Fields.Count - 1
wksSheet.Cells(1, 1).Offset(0, intNumber).Value = _
rcsEntry.Fields(intNumber).Name
wksSheet.Cells(1, 1).Offset _
(0, intNumber).Font.Bold = True
Next
wksSheet.Cells(1, 1).Offset(1, 0). _
CopyFromRecordset rcsEntry
wksSheet.Columns("A:IV").AutoFit
End With
rcsEntry.Close
objConn.Close
Set rcsEntry = Nothing
Set objConn = Nothing
MsgBox "Cities London from ""Test.mdb"" in sheet3!"
End If
On Error GoTo 0
Exit Sub
Fin:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Set rcsEntry = Nothing
Set objConn = Nothing
End Sub
Private Function ACC_Active() As Boolean
Dim ACCApp As Object
On Error Resume Next
Set ACCApp = GetObject(, "Access.Application")
If Err.Number = 429 Then
ACC_Active = False
Else
ACC_Active = True
End If
End Function

The following code belonged In "Module14"

Option Explicit
Sub MDB_delete()
If ACC_Active Then
MsgBox "Please close all ACCESS instances!"
Exit Sub
End If
If Dir(ThisWorkbook.Path & "\Test.mdb") <> "" Then _
Kill (ThisWorkbook.Path & "\Test.mdb"): _
MsgBox "Data base deleted!"
End Sub
Private Function ACC_Active() As Boolean
Dim ACCApp As Object
On Error Resume Next
Set ACCApp = GetObject(, "Access.Application")
If Err.Number = 429 Then
ACC_Active = False
Else
ACC_Active = True
End If
End Function

The following code belonged In "Module15"

Option Explicit
Private Declare Function FindWindow Lib "user32.dll" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function PostMessage Lib "user32.dll" _
Alias "PostMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any) As Long
Private Const WM_CLOSE = &H10
Private Const GCCLASSNAMEMSACCESS = "OMain"
Public Sub ACCESS_close()
Dim hwnd As Long
hwnd = FindWindow(GCCLASSNAMEMSACCESS, vbNullString)
PostMessage hwnd, WM_CLOSE, 0&, 0&
End Sub

The following code belonged In "Module16"

Option Explicit
Public Sub Sheet_Clear()
Sheet3.Cells.Clear
End Sub


Sample 2003

Sample 2007

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...