I have searched for solution for this problem for a while now and can't seem to find anything relevant. Is it possible to change column labels (titles) in table via VBA. The only way I find to do it is to create query based on table with parameters as SQL aliases. However it adds some more elements to my already complex data base, it is something I want to avoid. I do not want to change column names. Is there any solution to this problem or should I leave it as it is now?
Thanks for the time you took reading this and for answers!
I think that is what you want, but I am never greatly in favour of adding information to a table that could confuse future users.
Option Compare Database
Option Explicit
Sub Usage()
SetProperty "Table1", "ID", "Caption", "This is an ID"
End Sub
Sub SetProperty(TableName As String, Fieldname As String, _
PropertyName As String, PropertyValue As Variant, _
Optional PropertyType As Variant = dbText)
Dim db As DAO.Database
Dim fld As DAO.Field
Dim prp As DAO.Property
On Error GoTo Err_Property
Set db = CurrentDb
Set fld = db.TableDefs(TableName).Fields(Fieldname)
fld.Properties(PropertyName) = PropertyValue
''Debug.Print fld.Properties(PropertyName)
Exit Sub
Err_Property:
' Error 3270 means that the property was not found.
If DBEngine.Errors(0).Number = 3270 Then
' Create property, set its value, and append it to the
' Properties collection.
Set prp = fld.CreateProperty(PropertyName, _
PropertyType, PropertyValue)
fld.Properties.Append prp
Resume Next
Else
MsgBox Err.Description
End If
End Sub
Related
I am creating an Access 2019 database for small family business (dog breeding) so I setup some tables containing all details on the dogs and the owners. Just to give an idea (simplistic description of the situation):
Dogs
Name
Birth
Microchip
Etc…
Owners
Name
Address
Etc…
I was now trying to create a "Contract composer" for when we sell the dogs. So I made a new table "Contract" and a related form
Contract
Seller ->linked to Owners table
Buyer ->linked to Owners table
Dog ->linked to Dogs table
Price
And made a query to pull all relevant information from the related tables so that I can have
ContractQuery
Seller!Name
Seller!Address
Buyer!Name
Buyer!Address
Dog!Name
Dog!Birthdate
Dog!Microchip
Contract!Price
Everything so far is working perfectly fine.
Now I need to convert the ContractQuery fields in a form of "human readable" contract. I think the best way to do so is the MailMerge to a specific Word document, and I've already setup one. My problem is: how can I set a button into the Contract form so that the "contract.doc" is populated with the specific record I'm seeing now in the form?
I had made some researches and the most relevant information I've found is this
https://www.access-programmers.co.uk/forums/threads/run-mail-merge-from-vba.158126/
and this https://www.tek-tips.com/faqs.cfm?fid=3237
But they are related to old MS-Access so when I tried to apply it I had errors all around. Unluckily my VBA knowledge is far from being proficient and I was not able to make it work.
Can anyone help me, or address me to a solution?
Thanks in advance for any advice
OK I got it working thanks to Kostas K, pointing me in the fight direction. This is my final code, it might need some cleanup and tweaking (for example, the loop within the resulst is now redundant as I only have one result), but it is working :)
The solution is based on this post, should anyone need please have a look at it as reference for the template docx etc
Generating completed PDF forms using word docs and ms access
Option Explicit
Private Sub cmdMergeIt_Click()
On Error GoTo Trap
' **** defining project path as string to make this portable
Dim CurPath As String
CurPath = CurrentProject.path & "\"
' MsgBox (CurPath) 'debug
Dim TEMPLATE_PATH As String
TEMPLATE_PATH = CurPath & "Contratto.dotx"
Dim wApp As Word.Application
Dim wDoc As Word.Document
Dim rs As DAO.Recordset
Dim idx As Long
' *** intercepting the contract ID field from the launching form
Dim checkID As String
checkID = ID.Value
'MsgBox (checkID) 'debug
' **** defining a SQL query on my Access query
Dim strSQL As String
strSQL = "Select * from qContratto where ID =" & checkID & ""
' MsgBox (strSQL) 'debug
Set wApp = New Word.Application
wApp.Visible = False
' ***** changed the OpenRecordset to call my strSQL query insetad than reading the whole Access query
Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
If rs.EOF Then GoTo Leave
With rs
.MoveLast
.MoveFirst
End With
For idx = 1 To rs.RecordCount
Set wDoc = wApp.Documents.Add(TEMPLATE_PATH)
With wDoc
.Bookmarks("Prezzo").Range.Text = Nz(rs!Prezzo, vbNullString)
.Bookmarks("Venditore").Range.Text = Nz(rs!Venditore, vbNullString)
.Bookmarks("Acquirente").Range.Text = Nz(rs!Acquirente, vbNullString)
.Bookmarks("Cessione").Range.Text = Nz(rs!Cessione, vbNullString)
.Bookmarks("NomeCane").Range.Text = Nz(rs!NomeCane, vbNullString)
.Bookmarks("Riproduzione").Range.Text = Nz(rs!Riproduzione, vbNullString)
.Bookmarks("Sesso").Range.Text = Nz(rs!Sesso, vbNullString)
.ExportAsFixedFormat CurPath & rs!Acquirente & ".pdf", wdExportFormatPDF, False, wdExportOptimizeForOnScreen
.Close wdDoNotSaveChanges
' in the ExportAsFixedFormat here above called one of the SQL query values to make a unique and distinctive name. Also please note use of CurPath for portability
End With
Set wDoc = Nothing
rs.MoveNext
Next
Leave:
On Error Resume Next
If Not rs Is Nothing Then rs.Close
If Not wDoc Is Nothing Then wDoc.Close wdDoNotSaveChanges
If Not wApp Is Nothing Then wApp.Quit wdDoNotSaveChanges
On Error GoTo 0
Exit Sub
Trap:
MsgBox Err.Description, vbCritical
Resume Leave
End Sub
I am using one tab control with numerous pages, each stores one subform with a different number of columns. Every subform has to display some basic information, and on demand even more. The OnLoad event of each subform defines which column may visible or not.
As part of an export tool, I am trying to build a loop which returns every field name, field caption and the visibility of the column as a boolean.
Dim strAns As String
Dim ctl As Control
Dim sfrm As SubForm
Set sfrm = Forms![frm_Main]![frm_Sub]
For Each ctl In sfrm.Controls
strAns = ctl.Name & "_" & ctl.Caption & "_" & ctl.columnVisible
Debug.Print strAns
Next ctl
Currently it runs only using ctl.Name, but I have the feeling this may not be the right syntax for my use-case. It returns every field name AND additionally the name of the textbox beneath it in a new line, so basically this is twice as much information I need.
Does anyone have an idea, how to reach the other two properties?
For those who have the same problem, here is a possible workaround! In the meantime I figured out that I doesn't necessarily need the .Caption for my specific use-case.
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim rstQry As DAO.Recordset
Dim fldQry As DAO.Field
Set db = CurrentDb
Set qdf = db.QueryDefs("qrySource_frmSub")
Set rstQry = qdf.OpenRecordset
Dim dictHidden As New Scripting.Dictionary
For Each fldQry In rstQry.Fields
dictHidden.Add fldQry.Name, False
Next fldQry
qdf.Close
Dim frm As SubForm
Set frm = Forms![frm_Main]![frm_Sub]
For Each key In dictHidden.Keys
dictHidden(key) = frm.Controls.item(key).ColumnHidden
Next key
I have a form that creates two queries, exports them to Excel and then deletes them. However, when I hit an error on my exporting, it doesn't make it the deletions. How would I go about checking to see if they already exist? And if they do, delete them so I can re-create them with the new/updated data?
Code so far:
Dim qdfNewQry As Object
Dim qdfNewWS As Object
'//----- qdfNewQry
If Not IsNull(DLookup("myExportQry", "MSysObjects", "Name='myExportQry'")) Then
CurrentDb.QueryDefs.Delete qdfNewQry.Name
Set qdfNewQry = CurrentDb.CreateQueryDef("myExportQry", exportQry)
Else
Set qdfNewQry = CurrentDb.CreateQueryDef("myExportQry", exportQry)
End If
'//----- qdfNewWS
If Not IsNull(DLookup("myExportWS", "MSysObjects", "Name='myExportWS'")) Then
CurrentDb.QueryDefs.Delete qdfNewWS.Name
Set qdfNewWS = CurrentDb.CreateQueryDef("myExportWS", exportWS)
Else
Set qdfNewWS = CurrentDb.CreateQueryDef("myExportWS", exportWS)
End If
I'm getting the error "The expression you entered as a query parameter produced this error: 'myExportQry'" on the line If Not IsNull(DLookup("myExportQry", "MSysObjects", "Name='myExportQry'")) Then
I'm pretty lost it seems. Any help/advice/corrections would be greatly appreciated!
EDIT1:
Just for clarification, I'm wanting to delete the entire query. Other alternative solutions would also be welcome!
I wouldn't use the Dlookup function for this!
Private Sub Command1_Click()
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Set db = CurrentDb()
For Each qdf In db.QueryDefs
Debug.Print qdf.Name
If qdf.Name = "strQry" Then
CurrentDb.QueryDefs.Delete "strQry"
CurrentDb.QueryDefs.Refresh
Exit For
End If
Next qdf
Set qdf = Nothing
Set db = Nothing
End Sub
DLookup uses the following format:
DLookup([Field], [Table], [Criteria])
There's no field in MSysObjects named "MyExportQuery". So, the first argument in DLookup() is wrong.
Also, remember that when you use a reserved word (like "Name"), you need to enclose it in brackets.
I think you want to say,
DLookup("[ID]", "MSysObjects", "[Name]='myExportQry'")
That should either return a number or a NULL, so that will give you what you need to determine if the query already exists.
The above is untested, but logically it makes sense to me.
I use this. If the query is not there the DeleteObject will be "skipped"
On Error Resume Next
DoCmd.DeleteObject acQuery, "myExportQry"
Set qdfTemp = CurrentDb.CreateQueryDef("myExportQry", "SELECT From ....")
I've created the following code which I want to use in the future to get a list of all the fields in a table:
Private Sub btnGetFields_Click()
Dim myDBS As Database
Dim fldLoop As Fields
Dim fld As Field
Dim relLoop As Relation
Dim tdfloop As TableDef
Set myDBS = CurrentDb
With myDBS
' Display the attributes of a TableDef object's
' fields.
Debug.Print "Attributes of fields in " & _
.TableDefs("ALT_IDENTIFIER").Name & " table:"
'Error occurs in line below
Set fldLoop = .TableDefs("ALT_IDENTIFIER").Fields
For Each fld In fldLoop
Debug.Print " " & fld.Name & " = " & _
fld.Attributes
Next fld
.Close
End With
End Sub
But I'm getting a Type Mistmatch - Runtime Error 13 back when I run the code.
Why? fldloop is a Fields object - i.e. a collection of field objects right? which is what the TableDefs.Fields procedure returns so why am I getting this error?
Thanks
I was having same issue and i resolved it by changing "Field" to "DAO.Field":
Dim fld As DAO.Field
Maybe it helps another one.
Best regards
Sometimes passing values to their literal types in Access causes these kinds of errors, not sure why, a quick fix is usually to dimension your variable as an open data type instead e.g:
Dim fldloop as object
Otherwise you could re-write this line:
For Each fld In fldLoop
to
For Each fld In .TableDefs("ALT_IDENTIFIER").Fields
and forget dimensioning a separate variable all together
UPDATE:
Perhaps this would be more useful for SQL Server, if you only have access via MS Access then you should be able to use this example by looping through your linked tables and dynamically re-building a a Pass Through Query
What is the equivalent of 'describe table' in SQL Server?
Found the problem: the reason I was getting the error was because I wasn't referring to the exact field. Though I'm still unsure as to why an error was thrown on a Fields object that was assigned a Fields value.
Here's the code:
Dim f As Field
Dim fldTableDef As Field
Dim Rst As DAO.Recordset
Dim numField As Integer
Dim linkedTable As String
linkedTable = "ALT_IDENTIFIER"
Set Rst = CurrentDb.OpenRecordset(linkedTable)
numField = Rst.Fields.Count
'Loop through
Dim index As Integer
For index = 0 To numField - 1
If Rst.Fields(index).Type = dbDate Then
Debug.Print "Field: " & Rst.Fields(index).Name; " = Date/Time" & Rst.Fields(index).Value
End If
Next
I was trying to follow the instructions on this Microsoft post: http://support.microsoft.com/default.aspx?scid=kb;en-us;209891
to create an organization hierarchy chart based on a self referencing table, just like the example. I keep getting an error that the variable is undefined and VBA points to the line "Optional varReportToID As Variant", but the instructions say not to supply anything for this parameter. Is there anything I can do to make the code run? I didn't change the code, I changed the naming on my tables to match the variables listed. I am working in MS Access 2010, but the example is for an older version of MS.
Thanks!
Option Explicit
'=================Load Event for the Form=======================
'Initiates the routine to fill the TreeView control
'============================================================
Public Sub Form_Load()
Const strTableQueryName = "Employees"
Dim db As DAO.Database, rst As DAO.Recordset
Set db = CurrentDb
Set rst = db.OpenRecordset(strTableQueryName, dbOpenDynaset, dbReadOnly)
AddBranch rst:=rst, strPointerField:="ReportsTo", strIDField:="EmployeeID", strTextField:="LastName"
End Sub
'================= AddBranch Sub Procedure ======================
' Recursive Procedure to add branches to TreeView Control
'Requires:
' ActiveX Control: TreeView Control
' Name: xTree
'Parameters:
' rst: Self-referencing Recordset containing the data
' strPointerField: Name of field pointing to parent's primary key
' strIDField: Name of parent's primary key field
' strTextField: Name of field containing text to be displayed
'=============================================================
Sub AddBranch(rst As Recordset, strPointerField As String, _
strIDField As String, strTextField As String, _
Optional varReportToID As Variant)
On Error GoTo errAddBranch
Dim nodCurrent As Node, objTree As TreeView
Dim strCriteria As String, strText As String, strKey As String
Dim nodParent As Node, bk As String
Set objTree = Me!xTree.Object
If IsMissing(varReportToID) Then ' Root Branch.
strCriteria = strPointerField & " Is Null"
Else ' Search for records pointing to parent.
strCriteria = BuildCriteria(strPointerField, _
rst.Fields(strPointerField).Type, "=" & varReportToID)
Set nodParent = objTree.Nodes("a" & varReportToID)
End If
' Find the first emp to report to the boss node.
rst.FindFirst strCriteria
Do Until rst.NoMatch
' Create a string with LastName.
strText = rst(strTextField)
strKey = "a" & rst(strIDField)
If Not IsMissing(varReportToID) Then 'add new node to the parent
Set nodCurrent = objTree.Nodes.Add(nodParent, tvwChild, strKey, strText)
Else ' Add new node to the root.
Set nodCurrent = objTree.Nodes.Add(, , strKey, strText)
End If
' Save your place in the recordset so we can pass by ref for speed.
bk = rst.Bookmark
' Add employees who report to this node.
AddBranch rst, strPointerField, strIDField, strTextField, rst(strIDField)
rst.Bookmark = bk ' Return to last place and continue search.
rst.FindNext strCriteria ' Find next employee.
Loop
'--------------------------Error Trapping --------------------------
errAddBranch:
MsgBox "Can't add child: " & Err.Description, vbCritical, "AddBranch Error:"
Resume exitAddBranch
End Sub