How can you increase the size of a MDB field size using DAO?
You can do this much more easily with DDL:
Set db = CurrentDb
sSQL = "ALTER TABLE table1 ALTER Column atext text(150)"
db.Execute sSQL, dbFailOnError
Apparently, this is not available in MS Access 97, but in any version in the 15 year since, I would suggest that DDL is the simplest approach.
From http://www.freevbcode.com/ShowCode.asp?ID=4599:
Public Sub change_field_size(DBPath as string, _
tblName As String, fldName As String, fldSize As Integer)
' this routine changes the field size
Dim db As Database
Dim td As TableDef
Dim fld As field
On Error GoTo errhandler
Set db = OpenDatabase(DBPath)
Set td = db.TableDefs(tblName)
If td.Fields(fldName).Type <> dbText Then
' wrong field type
db.Close
Exit Sub
End If
If td.Fields(fldName).size = fldSize Then
' the field width is correct
db.Close
Exit Sub
End If
' create a temp feild
td.Fields.Append td.CreateField("temp", dbText, fldSize)
td.Fields("temp").AllowZeroLength = True
td.Fields("temp").DefaultValue = """"""
' copy the info into the temp field
db.Execute "Update " & tblName & " set temp = " & fldName & " "
' delete the field
td.Fields.Delete fldName
' rename the field
td.Fields("temp").Name = fldName
db.Close
'======================================================================
Exit Sub
errhandler:
MsgBox CStr(Err.Number) & vbCrLf & Err.Description & vbCrLf & "Change Field Size Routine", vbCritical, App.Title
End Sub
Related
On my workstation, I've been using Access in English. Some other computer that will use my form have it in French. Testing it recently, I found out that Boolean variable, even if declared as True/False, come out as Vrai/Faux.
Where it becomes a problem is when I need to use the variable in a text, like an insert or simply a request.
The only workaround I have right now is using another variable of type String and replace it from French to English. The problem with this is... it's two ugly line. I mean, there must be another way than having to that every time i might use a Boolean variable in a request?
EDIT: Here is two exemples.
SELECT [...] FROM [...] WHERE [...] in (false , " & SomeBooleanValue & ");
-- OR --
str_Sql = "INSERT INTO [...] VALUES ('" & form_Name & "', " & is_something & ")"
DoCmd.RunSQL str_Sql
You could use parameters with your two examples and then not worry about concatenating into your SQL string:
Sub Test_1()
Dim qdf As DAO.QueryDef
Dim rst As DAO.Recordset
Set qdf = CurrentDb.CreateQueryDef("", _
"PARAMETERS SomeBooleanValue BIT; " & _
"SELECT * FROM Table1 WHERE Field_2 = SomeBooleanValue")
With qdf
.Parameters("SomeBooleanValue") = True
Set rst = .OpenRecordset
End With
With rst
If Not (.BOF And .EOF) Then
.MoveFirst
Do
Debug.Print .Fields("Field_1") & " - " & .Fields("Field_2")
.MoveNext
Loop While Not .EOF
End If
End With
End Sub
and
Sub Test_2()
Dim qdf As DAO.QueryDef
Set qdf = CurrentDb.CreateQueryDef("", _
"PARAMETERS some_text TEXT(255), is_something BIT; " & _
"INSERT INTO Table1 VALUES (some_text, is_something)")
With qdf
.Parameters("some_text") = "Some random text"
.Parameters("is_something") = True
.Execute
End With
End Sub
You can use this format expression to force a True/False output string:
UKTrueFalse = Format(YourBooleanValue, "True;True;Fal\se")
As for your SQL, you could just use the numeric value:
SELECT [...] FROM [...] WHERE [...] IN (0 , " & Str(Abs(SomeBooleanValue)) & ");
I am using the below function to determine the field data types from whichever table is given in the function parameter. Basically the function reads the data type from the table and compares it to what it should be based on the "FieldDataTypes" table. If it doesn't match, then I would like to run an Alter table SQL statement as shown below. However I am realizing that once I open the recordset I am unable to alter the table. When I run the Sub/Function below I get the error:
The database could not lock table "TEST TABLE" because it is already in use by another person or process. 3211.
How can I get around this so that I can loop through the fields and still alter the data types as necessary?
Thanks,
Charlie
Sub TestReFormat()
FncFormatFields ("TEST TABLE")
End Sub
Public Function FncFormatFields(strTableName As String)
Dim rst As DAO.Recordset
Dim fld As Field
Dim strFieldName As String
Dim strSQL As String
Dim intDataType As Integer
Dim intDataTypeCheck As Integer
On Error GoTo FormatFieldsErr:
rstSQL = "SELECT * FROM [" & strTableName & "]"
Set rst = CurrentDb.OpenRecordset(strTableName)
For Each fld In rst.Fields
strFieldName = fld.Name
intDataType = fld.Type
Debug.Print strFieldName & " " & intDataType
intDataTypeCheck = DLookup("DataTypeInt", "FieldDataTypes", "[FieldName] = '" & strFieldName & "'")
Debug.Print intDataTypeCheck
If intDataTypeCheck <> intDataType Then
strSQL = "ALTER TABLE [" & strTableName & "] ALTER COLUMN [" & strFieldName & "] " & intDataTypeCheck & ""
DoCmd.RunSQL (strSQL)
End If
Continue2428:
Next fld
Exit Function
FormatFieldsErr:
If Err.Number = 2428 Then
Resume Continue2428
Else
MsgBox Err.Description & " " & Err.Number
End If
End Function
Break your function into two parts:
A Function that examines the table returns a SQL array of ALTER TABLE statements
A Function that executes the SQL array
The query that locks the table in 1) will be closed, allowing you to alter it in 2) without error.
PS: Use rstSQL = "SELECT TOP 1 * FROM [" & strTableName & "]" so you don't waste resources returning multiple rows.
You can update data in a table without locking. In fact FEW know that the Access database engine JET/ACE can even update columns in records that are currently in use and dirty by other users (the update has to be specific to the one column - this is possible in some cases).
However, to modify a table structure and data type? You will require full exclusive rights and other users cannot have the table open, and you need full lock rights to the whole database.
Since in this case the data is of no interest, only the table structure, you can use a TableDef object to get the table structure; this will get around the lock:
Public Function FncFormatFields(tablename As String)
Dim dbs As Database, tdf As TableDef, fld As Field
On Error GoTo FormatFieldsErr:
Set dbs = CurrentDb
Set tdf = dbs.TableDefs(tablename)
For Each fld In tdf.Fields
Dim fieldname As String
fieldname = fld.Name
Dim datatype As Integer
datatype = fld.Type
Debug.Print fieldname & " " & datatype
Dim finalDatatype As Integer
finalDatatype = DLookup("DataTypeInt", "FieldDataTypes", "[FieldName] = '" & fieldname & "'")
Debug.Print finalDatatype
If datatype <> finalDatatype Then DoCmd.RunSQL "ALTER TABLE [" & tablename & "] ALTER COLUMN [" & fieldname & "] " & finalDatatype & ""
Next
Continue2428:
Next fld
Exit Function
FormatFieldsErr:
If Err.Number = 2428 Then Resume Continue2428
MsgBox Err.Description & " " & Err.Number
End Function
Even if the data is of interest, TableDef has an OpenRecordset method that returns the data in the table.
It might also be possible to use a snapshot-type recordset, which doesn't have an open connection to the database, and therefore shouldn't be affected by the lock. (I didn't test this.)
Note: I've only tested this with an .accdb; if this works as well with an .mdb that would be good to know.
I am running an expression to loop through a recordset and with a string from each record run an update query on second table. Based on a LIKE match it updates a field to create a relation. I am having problem with Runtime Error '424' Object Required at CurrentDb.Execute.
Tables:
Transactions (main table to update)
TransactionType (relation table of types or categories)
TransSet (List of strings and transactiontype to set to)
Private Sub Toggle1_Click()
Dim db As DAO.Database
Dim rst As DAO.Recordset
Set db = CurrentDb Set rst = db.OpenRecordset("TransSet")
Do Until rst.EOF
CurrentDb.Execute ("UPDATE Transactions SET Transactions.TransactionType =" & (TransSet.TransTypeSet) & " WHERE ((Transactions.TransactionText1) Like * " & (TransSet.TransIdent) & "*))")
rst.MoveNext Loop
rst.Close Set rst = Nothing
End Sub
Reference the recordset object, not the table or query the recordset is based on.
Need apostrophe delimiters for text type fields paramaters.
CurrentDb.Execute ("UPDATE Transactions SET TransactionType ='" & rst!TransTypeSet & "'" & _
" WHERE TransactionText1 Like '*" & rst!TransIdent & "*'")
Thank you - I also had realised my error and fixed the code. I also changed the table name to not confuse with reserved words.
Private Sub Toggle1_Click()
Dim db As DAO.Database
Dim rst As DAO.Recordset
Set db = CurrentDb
Set rst = db.OpenRecordset("Select * FROM TransSet")
Do Until rst.EOF
CurrentDb.Execute ("UPDATE Trans SET trans.TransactionType =" & (rst!TransTypeSet) & " WHERE ((Trans.TransactionText1) Like '*" & (rst!TransIdent) & "*');")
' MsgBox ("UPDATE Trans SET trans.TransactionType =" & (rst!TransTypeSet) & " WHERE ((Trans.TransactionText1) Like '*" & (rst!TransIdent) & "*');")
rst.MoveNext
Loop
rst.Close
Set rst = Nothing
End Sub
Just getting to grips some VBA (this stuff's new to me so bear with us!)
From query ContactDetails_SurveySoftOutcomes, I'm trying to first find a list of all the unique values in the DeptName field in that query, hence the rsGroup Dim storing a Grouped query on the DeptName field.
I'm then going to use this grouped list as way of cycling through the same query again, but passing through each unique entry as a filter on the whole recordset and export each filtered recordset to its own Excel spreadsheet... see the Do While Not loop.
My code's tripping up on the DoCmd.TransferSpreadsheet ... rsExport part. I'm a bit new to this, but I guess my Dim name rsExport for the recordset isn't accepted in this method..?
Is there an easy fix to the code I've already started or should I be using a completely different approach to achieve all this?
Code:
Public Sub ExportSoftOutcomes()
Dim rsGroup As DAO.Recordset
Dim Dept As String
Dim myPath As String
myPath = "C:\MyFolder\"
Set rsGroup = CurrentDb.OpenRecordset("SELECT ContactDetails_SurveySoftOutcomes.DeptName " _
& "FROM ContactDetails_SurveySoftOutcomes GROUP BY ContactDetails_SurveySoftOutcomes.DeptName", dbOpenDynaset)
Do While Not rsGroup.EOF
Dept = rsGroup!DeptName
Dim rsExport As DAO.Recordset
Set rsExport = CurrentDb.OpenRecordset("SELECT * FROM ContactDetails_SurveySoftOutcomes " _
& "WHERE (((ContactDetails_SurveySoftOutcomes.DeptName)='" & Dept & "'))", dbOpenDynaset)
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, rsExport, myPath & Dept & "\" & Dept & " - Soft Outcomes Survey.xls", True
rsGroup.MoveNext
Loop
End Sub
Fixed Code:
Public Sub ExportSoftOutcomes()
Dim rsGroup As DAO.Recordset
Dim Dept As String
Dim myPath As String
myPath = "C:\MyFolder\"
Set rsGroup = CurrentDb.OpenRecordset("SELECT ContactDetails_SurveySoftOutcomes.DeptName " _
& "FROM ContactDetails_SurveySoftOutcomes GROUP BY ContactDetails_SurveySoftOutcomes.DeptName", dbOpenDynaset)
Do While Not rsGroup.EOF
Dept = rsGroup!DeptName
Dim rsExportSQL As String
rsExportSQL = "SELECT * FROM ContactDetails_SurveySoftOutcomes " _
& "WHERE (((ContactDetails_SurveySoftOutcomes.DeptName)='" & Dept & "'))"
Dim rsExport As DAO.QueryDef
Set rsExport = CurrentDb.CreateQueryDef("myExportQueryDef", rsExportSQL)
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "myExportQueryDef", myPath & Dept & "\" & Dept & " - Soft Outcomes Survey.xls", True
CurrentDb.QueryDefs.Delete rsExport.Name
rsGroup.MoveNext
Loop
End Sub
You're right that your rsGroup parameter is wrong, Access expects a table name or select query.
Try this code:
strExport = "SELECT * FROM ContactDetails_SurveySoftOutcomes " _
& "WHERE (((ContactDetails_SurveySoftOutcomes.DeptName)='" & Dept & "'))"
Set qdfNew = CurrentDb.CreateQueryDef("myExportQueryDef", strExport)
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "myExportQueryDef", myPath & Dept & "\" & Dept & " - Soft Outcomes Survey.xls", True
CurrentDb.QueryDefs.Delete qdfNew.Name 'cleanup
Hope that works
try this hope this will help you
Function Export2XLS(sQuery As String)
Dim oExcel As Object
Dim oExcelWrkBk As Object
Dim oExcelWrSht As Object
Dim bExcelOpened As Boolean
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim iCols As Integer
Const xlCenter = -4108
'Start Excel
On Error Resume Next
Set oExcel = GetObject(, "Excel.Application") 'Bind to existing instance of Excel
If Err.Number <> 0 Then 'Could not get instance of Excel, so create a new one
Err.Clear
On Error GoTo Error_Handler
Set oExcel = CreateObject("excel.application")
bExcelOpened = False
Else 'Excel was already running
bExcelOpened = True
End If
On Error GoTo Error_Handler
oExcel.ScreenUpdating = False
oExcel.Visible = False 'Keep Excel hidden until we are done with our manipulation
Set oExcelWrkBk = oExcel.Workbooks.Add() 'Start a new workbook
Set oExcelWrSht = oExcelWrkBk.Sheets(1)
'Open our SQL Statement, Table, Query
Set db = CurrentDb
Set rs = db.OpenRecordset(sQuery, dbOpenSnapshot)
With rs
If .RecordCount <> 0 Then
'Build our Header
For iCols = 0 To rs.Fields.Count - 1
oExcelWrSht.Cells(1, iCols + 1).Value = rs.Fields(iCols).Name
Next
With oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), _
oExcelWrSht.Cells(1, rs.Fields.Count))
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 1
.HorizontalAlignment = xlCenter
End With
oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), _
oExcelWrSht.Cells(1, rs.Fields.Count)).Columns.AutoFit 'Resize our Columns based on the headings
'Copy the data from our query into Excel
oExcelWrSht.Range("A2").CopyFromRecordset rs
oExcelWrSht.Range("A1").Select 'Return to the top of the page
Else
MsgBox "There are no records returned by the specified queries/SQL statement.", vbCritical + vbOKOnly, "No data to generate an Excel spreadsheet with"
GoTo Error_Handler_Exit
End If
End With
' oExcelWrkBk.Close True, sFileName 'Save and close the generated workbook
' 'Close excel if is wasn't originally running
' If bExcelOpened = False Then
' oExcel.Quit
' End If
Error_Handler_Exit:
On Error Resume Next
oExcel.Visible = True 'Make excel visible to the user
rs.Close
Set rs = Nothing
Set db = Nothing
Set oExcelWrSht = Nothing
Set oExcelWrkBk = Nothing
oExcel.ScreenUpdating = True
Set oExcel = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: Export2XLS" & vbCrLf & _
"Error Description: " & Err.Description _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function
DoCmd.TransferSpreadsheet expects its third parameter to be a String (variable or literal) specifying the name of a table or query. So, instead of opening a DAO.Recordset you could create a DAO.QueryDef named something like "forExportToExcel" with the same SQL code, then use that name in the TransferSpreadsheet call.
I have two tables and I have a form linking to one of them. I want to check a value and if it is true, add the record the other table by using VBA.
Can anyone help me, please?
This is my code, but it does not work:
Dim rec1 As DAO.Recordset
Dim rec2 As DAO.Recordset
Set rec1 = CurrentDb.OpenRecordset("TotalTPAq")
Set rec2 = CurrentDb.OpenRecordset("Visi")
rec1.MoveFirst
Do Until rec1.EOF
If rec1!Date = PlanDate.Value Then ' planDate is a text box
rec2.AddNew
rec2![Planing Date History] = PlanDate.Value
rec2.Update
rec2.Close
End If
rec1.MoveNext
Loop
rec1.Close
Set rec2 = Nothing
Set rec1 = Nothing
DoCmd.Close
This should provide a start for you:
'Run query to fill table
Private Sub btnRnQry_Click()
'No value entered
If IsNull(Me.txtEntry) Or Me.txtEntry = "" Then
MsgBox ("Is null or empty")
Else
'Assign value to variable
Dim entry As String
entry = Me.txtEntry
Dim sql As String
sql = "INSERT INTO tableTwo ([First Name],Surname,[Phone Number] )" & _
"SELECT * " & _
"FROM tableOne " & _
"WHERE [First Name] = '" & entry & "';"
'Run the SQL
DoCmd.RunSQL sql
End If
End Sub