I have created and manipulated an external database from the existing tables in my current database.
The matter is that I necessarily have to manipulate "Description" property in the new database fields.
When I try to retrieve "Description" property from cereated external database, response is that "Description" isn't a property (Error 3270, "property not found")
How could I do it?
I tried the following code:
Sub Actualizacomentarios()
Dim dbFinal As DAO.Database
Dim tbl As DAO.TableDef
Dim fld As DAO.Field
Dim tblFinal As DAO.TableDef
Dim fldFinal As DAO.Field
Dim prpFinal As DAO.Property
Set dbFinal = DBEngine.OpenDatabase("D:\Dropbox\Expedientes JLE nueva epoca activos\17002 - Fermin Torres. Programa\NuevoFoasat.accdb")
For Each tbl In CurrentDb.TableDefs
If InStr(tbl.Name, "JLE_") > 0 Then
For Each fld In tbl.Fields
Set tblFinal = dbFinal.TableDefs(tbl.Name)
Set fldFinal = tblFinal.Fields(fld.Name)
fldFinal.Properties("Description") = fld.Properties("Description") 'HERE OCCURS ERROR
Next fld
End If
Next tbl
dbFinal.Close
Set dbFinal = Nothing
Rewritten and working . Thanks to #HansUp
Sub Actualizacomentarios()
Dim dbFinal As DAO.Database
Dim tbl As DAO.TableDef
Dim fld As DAO.Field
Dim tblFinal As DAO.TableDef
Dim fldFinal As DAO.Field
Dim prpFinal As DAO.Property
Set dbFinal = DBEngine.OpenDatabase("D:\Dropbox\Expedientes JLE nueva epoca activos\17002 - Fermin Torres. Programa\NuevoFoasat.accdb")
For Each tbl In CurrentDb.TableDefs
If InStr(tbl.Name, "JLE_") > 0 Then
For Each fld In tbl.Fields
Set tblFinal = dbFinal.TableDefs(tbl.Name)
Set fldFinal = tblFinal.Fields(fld.Name)
On Error GoTo ErrorTrap
If Nz(fld.Properties("Description"), "") <> "" Then
Set prpFinal = fldFinal.CreateProperty("Description")
prpFinal.Type = dbText
prpFinal.Value = fld.Properties("Description")
fldFinal.Properties.Append prpFinal
'Debug.Print fldFinal.Name, fldFinal.Properties("Description")
fldFinal.Properties("Description") = fld.Properties("Description")
End If
On Error GoTo 0
Next fld
End If
Next tbl
dbFinal.Close
Set dbFinal = Nothing
Exit Sub
ErrorTrap:
If Err.Number = 3367 Then
Debug.Print "Property already exists on " & tbl.Name & " (Field: " & fld.Name & ")"
Else
Stop
Debug.Print "Not Found or empty on " & tbl.Name & " (Field: " & fld.Name & ")"
End If
Resume Next
End Sub
Related
I have a recordset TBLSOURCETARGETLINK that I want to update on an after update event.
I also need to ensure that no duplicates are present before I add the new record.
If the record exists, I just want to update the record and add new.
I am struggling with the VBA and the sequencing of how to do it.
Please could someone assist.
VBA currently looks like this:
Private Sub IsSource_AfterUpdate()
Dim VbaTableID As Integer
Dim VbaSystemID As Integer
Dim VbaFieldID As Integer
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim tabledef As String
Dim strcriteria As String
Dim rstSourceTarget As Recordset
Set rstSourceTarget = CurrentDb.OpenRecordset(Name:="tblsouretargetlink", Type:=RecordsetTypeEnum.dbOpenDynaset)
If IsNull(Me!TableID) Then
Else
VbaTableID = Me!TableID
End If
If IsNull(Me!SystemID) Then
Else
VbaSystemID = Me!SystemID
End If
If IsNull(Me!FieldID) Then
Else
Vbafield = Me!FieldID
End If
strcriteria = "[systemid] = '" & Me.SystemID & "' And [tableid] = " & Me.TableID And [FieldID] = " & Me.fieldid"
rs.FindFirst strcriteria
If .NoMatch Then
With rstSourceTarget
.AddNew
![SystemID] = VbaSystemID
![SourceTable] = VbaTableID
![SourceField] = VbaFieldID
.Update
End With
Else
With rstSourceTarget
.Edit
![IsSource] = -1
.Update
End If
End Sub
Thank you
Try this code:
Private Sub IsSource_AfterUpdate()
Dim VbaTableID As Integer
Dim VbaSystemID As Integer
Dim VbaFieldID As Integer
Dim db As DAO.Database
Dim strCriteria As String
Dim rstSourceTarget As Recordset
Set db = CurrentDb
' don't use CurrentDb for opening recordsets, it's dynamic, you can lose reference to database.
Set rstSourceTarget = db.OpenRecordset(Name:="tblsouretargetlink", Type:=RecordsetTypeEnum.dbOpenDynaset)
If Not IsNull(Me!TableID) Then
VbaTableID = Me!TableID
End If
If Not IsNull(Me!SystemID) Then
VbaSystemID = Me!SystemID
End If
If Not IsNull(Me!fieldid) Then
VbaFieldID = Me!fieldid
End If
strCriteria = "[systemid] = '" & Me.SystemID & "' And [tableid] = " & Me.TableID & " And [FieldID] = " & Me.fieldid
With rstSourceTarget
.FindFirst strCriteria
If .NoMatch Then
.AddNew
![SystemID] = VbaSystemID
![SourceTable] = VbaTableID
![SourceField] = VbaFieldID
.Update
Else
.Edit
![IsSource] = -1
.Update
End If
End With
End Sub
There are a lot of errors, so first of all add
Option Explicit
at the beginning of each module and recompile the project (Debug->Compile)
I have created a form to get all the field header names, but I'm unable to select multiple fields. Attached is for your reference.
Following is the code used to get the Headers from the Master Table:
Private Sub Form_Load()
'Call GetColumnNameFromIndex
'Call List4_Click
Dim rst As New ADODB.Recordset
rst.Open "SELECT * FROM Master_DataBase", CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
' Note: adOpenForwardOnly and adLockReadOnly are the default values '
' for the CursorType and LockType arguments, so they are optional here '
' and are shown only for completeness '
Dim ii As Integer
Dim ss As String
For ii = 0 To rst.Fields.Count - 1
ss = ss & "," & rst.Fields(ii).Name
Next ii
Me.List4.RowSource = ss
Debug.Print ss
Me.Requery
End Sub
Set your properties to Simple or Extended.
Sample VBA code may look like this.
Option Compare Database
Private Sub cmdOpenQuery_Click()
On Error GoTo Err_cmdOpenQuery_Click
Dim MyDB As DAO.Database
Dim qdef As DAO.QueryDef
Dim i As Integer
Dim strSQL As String
Dim strWhere As String
Dim strIN As String
Dim flgSelectAll As Boolean
Dim varItem As Variant
Set MyDB = CurrentDb()
strSQL = "SELECT * FROM tblCompanies"
'Build the IN string by looping through the listbox
For i = 0 To lstCounties.ListCount - 1
If lstCounties.Selected(i) Then
If lstCounties.Column(0, i) = "All" Then
flgSelectAll = True
End If
strIN = strIN & "'" & lstCounties.Column(0, i) & "',"
End If
Next i
'Create the WHERE string, and strip off the last comma of the IN string
strWhere = " WHERE [strCompanyCountries] in (" & Left(strIN, Len(strIN) - 1) & ")"
'If "All" was selected in the listbox, don't add the WHERE condition
If Not flgSelectAll Then
strSQL = strSQL & strWhere
End If
MyDB.QueryDefs.Delete "qryCompanyCounties"
Set qdef = MyDB.CreateQueryDef("qryCompanyCounties", strSQL)
'Open the query, built using the IN clause to set the criteria
DoCmd.OpenQuery "qryCompanyCounties", acViewNormal
'Clear listbox selection after running query
For Each varItem In Me.lstCounties.ItemsSelected
Me.lstCounties.Selected(varItem) = False
Next varItem
Exit_cmdOpenQuery_Click:
Exit Sub
Err_cmdOpenQuery_Click:
If Err.Number = 5 Then
MsgBox "You must make a selection(s) from the list", , "Selection Required !"
Resume Exit_cmdOpenQuery_Click
Else
'Write out the error and exit the sub
MsgBox Err.Description
Resume Exit_cmdOpenQuery_Click
End If
End Sub
Please customize to your specific needs.
My Code is:
Public Sub ImportCommonFields()
Set rs1 = CurrentDb.OpenRecordset("Imported Table" & " " & TableCtr)
Set cf = CurrentDb.OpenRecordset("CommonFields")
cf.AddNew
cf("FieldNames") = rs1.Fields
cf.Update
Set fld = Nothing
End Sub
I am currently getting the column names (Fields) from the table in rs1 and would like to import them to an existing table "CommonFields" under the column "FieldNames".
Loop the Fields collection:
Public Sub ImportCommonFields()
Dim fld As DAO.Field
Set rs1 = CurrentDb.OpenRecordset("Imported Table" & " " & TableCtr)
Set cf = CurrentDb.OpenRecordset("CommonFields")
For Each fld In rs1.Fields
cf.AddNew
cf("FieldNames").Value = fld.Name
cf.Update
Next
cf.Close
rs1.Close
Set fld = Nothing
End Sub
I wrote some VBA code to write data from a text file.
In the file I have this text:
H|3434|0104-00000107844/18|Peter|Smith|
D|345345345|"III"|
| character is a delimiter for separating columns in the table.
Private Sub Polecenie8_Click()
Dim fieldname As String
fieldname = "d:\odebrane\tekst1.txt"
Dim strLineInput As String
Dim tekst As String
Dim strLineArray As Variant
Dim FileNum As Integer
FileNum = FreeFile()
Open fieldname For Input As #FileNum
Do While Not EOF(FileNum)
Line Input #FileNum, strLineInput
strLineArray = Split(strLineInput, "|")
tekst = strLineArray(3)
Loop
Me.Tekst0 = tekst
Close #FileNum
End Sub
strLineArray(0) is equal D not H and I don't know why.
I want to save this array in a table, so I want strLineArray(0) to be equal to H and strLineArray(5) to be equal to D.
How about something like this?
Sub imptxttable()
Dim DB As DAO.Database
Dim rst As DAO.Recordset
Dim fld As DAO.Field
Dim strSQL As String
Dim strfilepath As String
strfilepath = "your_file.txt"
strSQL = "Select * FROM " & strfilepath
Set DB = OpenDatabase("c:\test", False, False, "Text; Format=Delimited(|);HDR=Yes;CharacterSet=437")
Set rst = DB.OpenRecordset(strSQL)
Debug.Print rst.Fields(0).Name, rst.Fields(0)
With rst
.MoveLast
Debug.Print .RecordCount
.MoveFirst
For Each fld In rst.Fields
Debug.Print fld.Name
Next
End With
rst.Close
DB.Close
Set rst = Nothing
Set DB = Nothing
End Sub
In Access 2007 I need to select all the short-text fields in a table.
VBA code should look like this:
Dim strClient As String
Set dbs = CurrentDb()
Debug.Print Me.ID
strClient = "Select * from ANG_CLIENTS where DATA_TYPE='TEXT' AND ID=" & Me.ID
Set rs = dbs.OpenRecordset(strClient)
I get "Runtime error 3061. Too few parameters. Expected 1" on the last assignment.
You need to define a custom function to loop through the recordset fields and extract the names of text fields only.
The names can then be added to your SQL script.
Public Function TextDataFileds(rs As DAO.Recordset) As String
Dim fld As DAO.Field, item As String
For Each fld In rs.Fields
If fld.Type = 10 Then 'dbText
item = IIf(Len(item) = 0, fld.Name, item & ", " & fld.Name)
End If
Next fld
TextDataFileds = item
End Function
You can then call it like this:
Sub Test()
On Error GoTo ErrProc
Dim rs As DAO.Recordset
Set rs = CurrentDb().OpenRecordset("SELECT TOP 1 * FROM ANG_CLIENTS;")
Dim sql_ As String
sql_ = "SELECT " & TextDataFileds(rs) & " FROM ANG_CLIENTS WHERE ID=" & Me!ID
rs.Close
Set rs = Nothing
Set rs = CurrentDb().OpenRecordset(sql_)
'....
Leave:
rs.Close
Set rs = Nothing
On Error GoTo 0
Exit Sub
ErrProc:
MsgBox Err.Description, vbCritical
Resume Leave
End Sub