I have been using a vba code to make my work life easier but for some reason it stopped working as supposed to. What it does it gets a number from my DB and goes to website to find relevant certificate assigned to this number (company), then it reads the grade and expiry date which are to be recorded in same DB. The issue is now when it goes to
rs.fields("Expiry").Value = Split(sResult, "|")(1)
it throws a Runtime error 3421 which i believe is due to column being formatted as for date data type but it worked correctly for several months..? It work when changed data type to text however that will mess it up as later I use it in queries and reports and need it as a date.
Any ideas why it changed and how to fix it please?
Thanks
MD
Sub Get_BRCDirectory_Data()
Dim sCode, rs As DAO.Recordset, dic As Object, sResult As String, i As Long
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = 1
Set rs = CurrentDb.OpenRecordset("Approved")
If Not (rs.BOF And rs.EOF) Then
rs.MoveFirst
Do
sCode = rs.fields("SupplierCode").Value
If sCode <> "" Then
If Not dic.Exists(sCode) Then
sResult = GetGradeExpiryDate(CStr(sCode))
rs.Edit
rs.fields("Grade").Value = Trim(Split(sResult, "|")(0))
rs.fields("Expiry").Value = Split(sResult, "|")(1)
rs.UPDATE
dic(sCode) = Array(rs.fields("Grade").Value, rs.fields("Expiry").Value)
Else
rs.Edit
rs.fields("Grade").Value = dic(sCode)(0)
rs.fields("Expiry").Value = dic(sCode)(1)
rs.UPDATE
End If
End If
rs.MoveNext
Loop Until rs.EOF
End If
MsgBox "Done", 64
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
The following code is meant to compare a field value PURE_QP1 of a recordset to another field value PURE_QP1 of another second set. But i am getting end of statement expected error. My knowledge of Access vba is admittedly low.
The code is meant to first check if the productcode is present in recordset rst.
if it is, then it checks if it is compliant by finding its PURE_QP1 (which coud be more than 1) in another table. the condition for compliance is such that all its QP1s must be found in the table.
Dim db As DAO.Database
Dim rst As Recordset
Dim rst1 As Recordset
If Nz(Me!Combo_Product_number) <> "" Then
Set db = CurrentDb
Set rst = db.OpenRecordset("Q_compliant_FCM_EU", dbOpenDynaset)
Set rst1 = db.OpenRecordset("T_DOSSIER_FPL", dbOpenDynaset)
Do While Not rst.EOF
If rst.Fields("PRODUCT_CODE") = Me!Combo_Product_number Then
rst1.FindFirst "[PURE_QP1] = '"rst.Fields("PURE_QP1")"'"
If rst.NoMatch Then
MsgBox ("Product code is NOT compliant to FPL")
Exit Sub
End If
rst1.FindNext"[PURE_QP1] = '"rst.Fields("PURE_QP1")"'"
Loop
MsgBox ("Product code is compliant to FPL")
Else
MsgBox ("Product is not available in FCM_EU")
End If
End If
End Sub
Expected end of staement error is showing in
rst1.FindFirst "[PURE_QP1] = '"rst.Fields("PURE_QP1")"'"
and
rst1.FindNext"[PURE_QP1] = '"rst.Fields("PURE_QP1")"'"
You have an extra End If just before End Sub. That End If should go above Loop command to close the If rst.Fields("PRODUCT_CODE") = Me!Combo_Product_number Then if block.
Also your code regarding rst1 is wrong.
rst1.FindFirst "[PURE_QP1] = '"rst.Fields("PURE_QP1")"'"
should be
rst1.FindFirst "[PURE_QP1] = '" & rst.Fields("PURE_QP1") & "'"
the & sign to join strings are missing in your code.
PS: Have no idea what your code supposed to do, because your find first and find next logic seems to be incorrect.
I have form in which user have to enter company name, to avoid duplicates I wrote On_Exit event for data entry field. It checks all the records and if it finds duplicate it notifies user. Problem is that I use same form for entered data viewing and then doing it same On_Exit event shows duplicate warning despite entry not being duplicate. It happens because code check for all entries and since it is already in database it founds itself and raises false alarm, it is a code flaw, but I have no idea how to avoid. Can somebody offer clever way to avoid this problem without creating two identical forms (except one without duplicate checking)?
My code for duplicate checking:
Private Sub Pareisk_pav_Exit(Cancel As Integer)
Dim Par_pav As String
Dim rst As DAO.Recordset
Dim Counter As Long
Set rst = CurrentDb.OpenRecordset("tblPareiskejai")
Do Until rst.EOF
Par_pav = rst(1)
If rst(1) = Me.Pareisk_pav.Value Then
Me.WarningLB.Caption = "Entry with this name already exist"
Exit Do
Else
Me.WarningLB.Caption = ""
End If
rst.MoveNext
Loop
Exit Sub
I have tried to implement Counter in my code to ignore first match, but in this case it catches only second duplicate then entering new entry.
Counter solution (not working as intended) I have tried:
Do Until rst.EOF
Par_pav = rst(1)
If rst(1) = Me.Pareisk_pav.Value Then
Counter = Counter + 1
If Counter = 2 Then
Me.WarningLB.Caption = "Entry with this name already exist"
Exit Do
End If
Else
Me.WarningLB.Caption = ""
End If
rst.MoveNext
Loop
I suddenly come up with a solution myself. Since new entry gets new ID even before saved I thought I can use it in my advantage and added And rst(0) <> Me.ID.Value to my if clause. So far it works fine. Full edited code:
Private Sub Pareisk_pav_Exit(Cancel As Integer)
Dim Par_pav As String
Dim rst As DAO.Recordset
Dim marker As Boolean
Set rst = CurrentDb.OpenRecordset("tblPareiskejai")
Counter = 0
Do Until rst.EOF
Par_pav = rst(1)
If rst(1) = Me.Pareisk_pav.Value And rst(0) <> Me.ID.Value Then
Me.WarningLB.Caption = "Name already exist!"
Exit Do
Else
Me.WarningLB.Caption = ""
End If
rst.MoveNext
Loop
Exit Sub
End Sub
I admit to being a bit of a novice, but have designed myself a very handy personal MS Access database. I have tried to find a solution to the following on the net, but have been unsuccessful so far, hence my post (the first time I've done this).
I have a marquee on a form in MS Access, which scrolls the count of "incomplete tasks" to do. A "Tasks COUNT Query" provides a number from zero upwards. After the form loads, the code below scrolls a message (right to left) on the marquee in the form "There are X tasks requiring action." X is the number provided from the "Tasks COUNT Query". I would like the text string on the marquee to update on each loop, so that when I mark a task as complete, the next pass on the marquee shows the number (X) as being the updated count.
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim Number As String
Set db = CurrentDb
Set rst = db.OpenRecordset("Tasks COUNT Query")
If Not (rst.EOF And rst.BOF) Then
Do While Not rst.EOF
Number = rst![Tasks]
strTxt = strTxt & "There are " & Number & " tasks requiring action."
rst.MoveNext
Loop
End If
rst.Close
strTxt = Left(strTxt, Len(strTxt)) 'remove the coma at the end
strTxt = Space(30) & strTxt 'start position
Set rst = Nothing
Set db = Nothing
Me.TimerInterval = 180
End Sub
The following code runs on the form timer interval:
Private Sub Form_Timer()
Dim x
On Error GoTo Form_Timer_Err
x = Left(strTxt, 1)
strTxt = Right(strTxt, Len(strTxt) - 1)
strTxt = strTxt & x
lblMarqTask.Caption = Left(strTxt, 180)
Exit Sub
Form_Timer_Exit:
Exit Sub
Form_Timer_Err:
Me.TimerInterval = 0
Exit Sub
End Sub
I would be grateful for any assistance :)
To answer you question: -
I would like the text string on the marquee to update on each loop
To do this you need to place your code that collects the string into its own procedure and then pick a time to call it. I.e.
Move the Form_Load() code into its own procedure
Private Sub GetString()
Dim db As DAO.Database
... [The remaining code] ...
Me.TimerInterval = 180
End Sub
Change Form_Load() to call the new procedure
Private Sub Form_Load()
GetString
End Sub
Have the timer call the new procedure every so often to update the marquee (also known as ticker tape).
Private Sub Form_Timer()
Dim x
Static LngTimes As Long
On Error GoTo Form_Timer_Err
LngTimes = LngTimes + 1
If LngTimes = 100 Then
GetString
LngTimes = 0
End If
x = Left(StrTxt, 1)
StrTxt = Right(StrTxt, Len(StrTxt) - 1)
StrTxt = StrTxt & x
lblMarqTask.Caption = Left(StrTxt, 180)
Exit Sub
Form_Timer_Exit:
Exit Sub
This will update it every 100 times the timer runs. I have tested this and it works, albeit causing a judder in marquee scrolling.
I would like to take the time to give you some extra support in your code that may help understand VBA and make things clearer/easier for you in any future development.
The changes I have supplied are minimal to give you the desired result within the code you have currently. However it does mean I carried some issue across with it. I would perform the same feature with the below: -
Option Compare Database
Option Explicit
Private StrStatus As String
Private Sub GetStatus()
Dim Rs As DAO.Recordset
Set Rs = CurrentDb.OpenRecordset("SELECT count([Task]) FROM [TblTasks] WHERE [Done] = 'No'")
StrStatus = "There are " & Rs(0) & " tasks requiring action."
Rs.Close
Set Rs = Nothing
End Sub
Private Sub Form_Load()
Me.TimerInterval = 180
Me.lblMarqTask.Caption = ""
End Sub
Private Sub Form_Timer()
Static StrStatus_Lcl As String
If StrStatus_Lcl = "" Then
GetStatus
StrStatus_Lcl = StrStatus & Space(30)
If Me.lblMarqTask.Caption = "" Then Me.lblMarqTask.Caption = Space(Len(StrStatus_Lcl))
End If
Me.lblMarqTask.Caption = Right(Me.lblMarqTask.Caption, Len(Me.lblMarqTask.Caption) - 1) & Left(StrStatus_Lcl, 1)
StrStatus_Lcl = Right(StrStatus_Lcl, Len(StrStatus_Lcl) - 1)
End Sub
The result is the string scrolling will remain smooth the value get updates with each iteration.
To talk through what I have done here.
'Option Explicit' Is always good practice to have at the top of your modules/code, it forces you to declare your variables which can save you a headache in the future. This can be automatically added with new code object by enabling 'Require Variable Declaration' in 'Tools' > 'Options' of the VBA Developer environment (also known as the VBE).
Its not clear what the query was doing but to save on a loop I change it to return a single value that I could use. SELECT count([Task]) FROM [TblTasks] WHERE [Done] = 'No' will return a count of all items in TblTasks where the column Done equals No.
In format load I set the timer interval as this only needs setting once and I also ensured the marquee was empty before it run.
The timer keeps a local copy of the status that it remembers. Declaring with the word Static means the content of the variable is not lost between executions in the way a Dim declared variable would be.
If the local copy is empty (i.e. we have used it all up) then update what the status is (GetStatus) and get a new copy.
I hope this has been of help!
When a particular form loads I need to grab a distinct list of locations from a table, with the eventual goal of displaying them to the user (baby steps though, I'll get to that).
The code below generates no error, but when I try to loop through the recordset returned by my query, I get an error in relation to the integer i.
Run-time error '6': Overflow
I've tested the query and it does return the results that I expect, so I believe that my handling of the Recordset object my be the issue.
what am I doing wrong here?
Private Sub Form_load()
Dim DB As DAO.Database
Set DB = CurrentDb ' Set the DB object to use
'**
' Grab a recordset containing distinct locations
'*
Dim RS As DAO.Recordset
Set RS = DB.OpenRecordset( _
"SELECT DISTINCT [Active Directory].[AD Location] FROM [Active Directory]" _
)
Dim i As Integer: i = 0
Dim locations() As String
ReDim locations(0)
'**
' Make an array of the locations to display
'*
If Not (RS.EOF And RS.BOF) Then ' Ensure that the recordset is not empty
RS.MoveFirst ' Move to the first record (unnecessary here, but good practice)
'**
' Loop through the recordset and extract the locations
'*
Do Until RS.EOF = True
locations(i) = RS![AD Location]
i = i + 1
ReDim Preserve locations(i)
Loop
Else
'**
' Tell the user that there are no records to display
'*
Call MsgBox( _
"Sorry, something went wrong and there are no locations to display." & vbCrLf & vbCrLf & _
"Please ensure that the Active Directory table is not empty.", _
vbExclamation, _
"You'd better sit down, it's not good news..." _
)
End If
RS.Close ' Close the recordset
Set RS = Nothing ' Be a hero and destroy the now defunct record set
End Sub
If I'm not missing something, you could just use GetRows:
Dim locations As Variant
RS.MoveLast
i = RS.RecordCount
RS.MoveFirst
locations = RS.GetRows(i)
Thanks to #Arvo who commented that I had forgotten to move to the next record in my do loop.
Adding RS.MoveNext to the loop fixed the problem.
Do Until RS.EOF = True
locations(i) = RS![AD Location]
i = i + 1
ReDim Preserve locations(i)
RS.MoveNext
Loop
You seem to know what you are doing so my question is probably pointless as I'm sure you have a good reason, BUT... why are you stuffing the recordset values into an Array?... Or more specifically how are you displaying the results to the user in the end?
I ask because it would seem to be much simpler to just bind your SQL statement into a control (subform, combobox, listbox etc.) rather than iterating through records like your doing. But, as I said I imagine you have your reasons for doing it that way.