I got it to just make a list of everything, but I need to do some grouping. my idea was to get a list of addresses, then as I loop through those addresses, filter another query with the information I want to display. If I do that, I don't get an error, but it hangs the program. I'm assuming it's a problem with the loop, but I'm not sure how. Any suggestions?
Public Function getActionItems(strID As String, strType As String) As String
Dim dbs As DAO.Database
Dim qdf As DAO.QueryDef
Dim qdfAddress As DAO.QueryDef
Dim rst As DAO.Recordset
Dim rstAddress As DAO.Recordset
Dim s As String
Set dbs = CurrentDb
'Get the parameter query
Set qdf = dbs.QueryDefs("qryActionItems")
Set qdfAddress = dbs.QueryDefs("qryActionItemsAddresses")
'get all records
Set rst = qdf.OpenRecordset()
Set rstAddress = qdfAddress.OpenRecordset()
'get all records with the submisison number
rstAddress.filter = "submission_number=" & strID
Set rstAddressFiltered = rstAddress.OpenRecordset
'cycle through the addresses
If Not rstAddressFiltered.EOF Then
rstAddressFiltered.MoveFirst
s = s + "<strong>" & rstAddressFiltered!Address & "</strong>" & vbLf & "<ol>"
Do
'filter for the address
rst.filter = "submission_number=" & strID & "AND Address=" & """ & rstAddressFiltered!Address & """
Set rstFiltered = rst.OpenRecordset
'cycle through the records with the address
If Not rstFiltered.EOF Then
rstFiltered.MoveFirst
Do
s = s + vbTab & "<li>" & rstFiltered!Address & " - " & rstFiltered!Notes & " - " & rstFiltered!Due_date & "</li>" & vbLf
rstFiltered.MoveNext
Loop Until rstFiltered.EOF
End If
Loop Until rstAddressFiltered.EOF
s = s + "</ol>"
End If
End Function
Edit: I think it may be that I missed the .movenext, but I haven’t had a chance to try it.
The main query has
submission_number, type, address, notes
I'm trying to get something like
123 main st
Foo bar
Bar foo
126 main st
Notes
When I run the query I won't know what or how many addresses I have. So I thought I would use query1 to grab the addresses, then use the addresses in query1 to filter query2, printing those results.
If you see a better approach, I'm open!
Filter criteria has syntax errors. Need a space in front of AND. Quote mark delimiters are wrong. Use apostrophe instead of trying to double up quote mark.
rst.filter = "submission_number=" & strID & " AND Address='" & rstAddressFiltered!Address & "'"
Related
I've commented out the section to add the attachment because I know it works, but the files currently aren't present to be attached. I'm new to VBA and am missing something. My data is simply employee number, check date (send_checkdt), check number, name, etc. The query has no parameters, which is why I'm doing the select based on the form date defined in strSQL.
When I run it I immediately get an over and it exits. Previously I was only able to send the email to the first person in the query and the record didn't advance. The email part is working correctly, I'm just not processing the data correctly.as
What am I missing?
Private Sub Command1_Click()
Dim Msg As String
Dim F_attach As String
Dim O As Outlook.Application
Dim M As Outlook.MailItem
Dim DT As String
DT = Forms!Form1!frmCheckDt
Dim strSQL As String
strSQL = "SELECT * FROM qryMailList Where send_checkdt=" & DT
Dim dbs As DAO.Database
Dim Mlist As DAO.Recordset
'Dim Mfiltered As DAO.Recordset
Set dbs = CurrentDb
Set Mlist = dbs.OpenRecordset(strSQL, dbOpenDynaset)
Set O = New Outlook.Application
Set M = O.CreateItem(olMailItem)
Mlist.MoveFirst
Do Until Mlist.EOF
Msg = "Dear " & Mail_FullName & "," & vbCrLf & vbCrLf & _
"Your payroll check number " & Send_CheckNo & " was deposited on " & _
send_checkdt & " for " & Format(Send_NetPay, "Currency") & "." & vbCrLf & vbCrLf & _
"Sincerely," & vbCrLf & Send_CoName
F_attach = "f:\archives\CK" & Mail_emp & "_" & Send_CheckNo & ".pdf"
With M
.BodyFormat = olFormatPlain
.Body = Msg
.To = Mail_Email
.Subject = "Direct Deposit " & send_checkdt
' .Attachments.Add F_attach
.Display
End With
Mlist.MoveNext
Loop
DoCmd.Close
Set M = Nothing
Set O = Nothing
Set Mlist = Nothing
Set dbs = Nothing
Set qdf = Nothing
Set Mfiltered = Nothing
End Sub
I moved
set O=New Outlook.Application and
set M=O.CreateItem(olMailItem)
to be below
Do Until Mlist.EOF and it works correctly.
I also had to further identify my data fields by adding Mlist! to each. Without identifying Mlist it prodcued the correct number of emails but no data was filled in. Thank you to everyone that offered comments.
I am trying to use this code to calculate median from my query which has these criteria:
<[Form]![testForm2]![crit1] And >[Form]![testForm2]![crit2] and <[Form]![testForm2]![Age1] And >[Form]![testForm2]![Age2]
without these criteria function works well and gives for every task median based on "MP", however when I put in there my criteria I receive error:
error - Too few parameters. Expected 4 and then it says 'Object Variable or With block not set'
my input: DMedian("MP";"testForm2";"[TASK]= '" & [TASK] & "'")
*even when the Form is open it end up with the error.
*I probably need to find a different way to filter this query from the form, but I don't know how
Public Function DMedian(FieldName As String, _
TableName As String, _
Optional Criteria As Variant) As Variant
' Created by Roger J. Carlson
' http://www.rogersaccesslibrary.com
' Terms of use: You may use this function in any application, but
' it must include this notice.
'Returns the median of a given field in a given table.
'Returns -1 if no recordset is created
' You use this function much like the built-in Domain functions
' (DLookUp, DMax, and so on). That is, you must provide the
' 1) field name, 2) table name, and 3) a 'Where' Criteria.
' When used in an aggregate query, you MUST add each field
' in the GROUP BY clause into the into the Where Criteria
' of this function.
' See Help for more on Domain Aggregate functions.
On Error GoTo Err_Median
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Dim RowCount As Long
Dim LowMedian As Double, HighMedian As Double
'Open a recordset on the table.
Set db = CurrentDb
strSQL = "SELECT " & FieldName & " FROM " & TableName
If Not IsMissing(Criteria) Then
strSQL = strSQL & " WHERE " & Criteria & " ORDER BY " & FieldName
Else
strSQL = strSQL & " ORDER BY " & FieldName
End If
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
'Find the number of rows in the table.
rs.MoveLast
RowCount = rs.RecordCount
rs.MoveFirst
'Determine Even or Odd
If RowCount Mod 2 = 0 Then
'There is an even number of records. Determine the low and high
'values in the middle and average them.
rs.Move Int(RowCount / 2) - 1
LowMedian = rs(FieldName)
rs.Move 1
HighMedian = rs(FieldName)
'Return Median
DMedian = (LowMedian + HighMedian) / 2
Else
'There is an odd number of records. Return the value exactly in
'the middle.
rs.Move Int(RowCount / 2)
'Return Median
DMedian = rs(FieldName)
End If
Exit_Median:
'close recordset
rs.Close
Exit Function
Err_Median:
If Err.number = 3075 Then
DMedian = 0
Resume Exit_Median
ElseIf Err.number = 3021 Then
'EOF or BOF ie no recordset created
DMedian = -1
Resume Exit_Median
Else
MsgBox Err.Description
Resume Exit_Median
End If
End Function
The parameter separation character is comma and you are using a semi-colon
CHANGE:
DMedian("MP";"testForm2";"[TASK]= '" & [TASK] & "'")
TO:
DMedian("MP", "testForm2", "[TASK]= '" & [TASK] & "'")
Solution was to refer the text boxes in SQL declaration, Thank you guys
like this:
HAVING (((Data.[REV]< " & Me.crit1 & ") And (Data.[REV])>" & Me.crit2 & ") AND ((Reg.Age)<" & Me.Age1 & " And (Reg.Age)>" & Me.Age2 & " " & SQLcritComplete & "));"
NOT like this:
"HAVING (((Data.[REV]<[Form]![testForm2]![crit1]) And (Data.[REV])>[testForm2]![crit2]) AND ((Reg.Age)<[Form]![testForm2]![Age1] And (Reg.Age)>[Form]![testForm2]![Age2] & SQLcritComplete & "));"
I need to scrub a regularly received Access database so that all of its tables can be exported to "clean" CSVs and then imported by Base SAS via PROC IMPORT.
I am not experienced with Access VBA or programming in general, but I attempted to kitbash a script to loop through every field in every table and replace certain characters. It doesn't appear to work and I get several "Type Conversion Failure" errors while it's running.
Public Sub ReplaceCharAllTables()
Dim strSQL As String
Dim fld As DAO.Field
Dim db As DAO.Database
Set db = CurrentDb()
Dim obj As AccessObject, dbs As Object
Set dbs = Application.CurrentData
' Cycle through all tables in database
For Each obj In dbs.AllTables
' Cycle through all fields in the table
For Each fld In db.TableDefs("[" & obj.Name & "]").Fields
If fld.Type = dbText And Not IsNull(fld) Then
strSQL = "Update [" & obj.Name & "] Set [" & fld.Name & "]= Replace([" & fld.Name & "],Chr(10),'. ')"
DoCmd.RunSQL strSQL
strSQL = "Update [" & obj.Name & "] Set [" & fld.Name & "]= Replace([" & fld.Name & "],Chr(13),'. ')"
DoCmd.RunSQL strSQL
End If
Next
Next obj
End Sub
Note that this particular code current only attempts to remove two characters. It's just a temporary testbed.
EDIT 2016.11.30: Just wanted to say that Andre's solution was perfect. I ended up needing to make a couple minor tweaks, particularly to also look at "memo" fields in addition to text fields and to write the helpful debug info to a text file rather than to the size-limited Immediate Window. Looping through an array of character codes was deceptively clever.
Public Sub ReplaceCharAllTables()
Dim strSQL As String
Dim fld As DAO.Field
Dim db As DAO.Database
Dim td As DAO.TableDef
Dim strFld As String
Dim arCharCodes As Variant
Dim code As Variant
Dim strFolder As String
Dim n As Integer
Dim strUpdate As String
' Get stuff setup save debug.print log file
strFolder = Application.CurrentProject.Path & "\" & Application.CurrentProject.Name & "_RemoveCharLog.txt"
n = FreeFile()
Open strFolder For Output As #n
' all charcodes to replace
arCharCodes = Array(10, 13, 44)
Set db = CurrentDb()
' Cycle through all tables in database
For Each td In db.TableDefs
' Ignore system tables
If Not (td.Name Like "MSys*" Or td.Name Like "USys*") Then
' Cycle through all fields in the table
For Each fld In td.Fields
If fld.Type = dbText Or fld.Type = dbMemo Then ' Check if field is text or memo
' Cycle through all character codes to remove
For Each code In arCharCodes
strFld = "[" & fld.Name & "]"
strSQL = "UPDATE [" & td.Name & "] " & _
"SET " & strFld & " = Replace(" & strFld & ", Chr(" & code & "), '. ') " & _
"WHERE " & strFld & " LIKE '*" & Chr(code) & "*'"
db.Execute strSQL
strUpdate = "Updated " & db.RecordsAffected & " records."
'Start printing logs
Debug.Print strSQL
Debug.Print strUpdate
Print #n, strSQL
Print #n, strUpdate
Next code
End If
Next fld
End If
Next td
End Sub
In principal there is nothing wrong with your code as far as I can see. The main problem may be that it also attempts to update all system tables - check "System objects" in the Navigation options of the navigation pane to see them.
They start with MSys or USys.
A few other things to improve:
You need the TableDef objects anyway, so you can directly loop them instead of AllTables
A table field cannot be Null, so this check isn't needed
For efficiency you want to only update rows where the column actually contains the searched character, so I add a WHERE clause
To avoid duplicate code, put all character codes to replace in an array for an additional loop.
Use db.Execute instead of DoCmd.RunSQL: it avoids the need for DoCmd.SetWarnings False, and gives you the number of affected records.
My suggestion:
Public Sub ReplaceCharAllTables()
Dim strSQL As String
Dim fld As DAO.Field
Dim db As DAO.Database
Dim td As DAO.TableDef
Dim strFld As String
Dim arCharCodes As Variant
Dim code As Variant
' all charcodes to replace
arCharCodes = Array(10, 13)
Set db = CurrentDb()
' Cycle through all tables in database
For Each td In db.TableDefs
' Ignore system tables
If Not (td.Name Like "MSys*" Or td.Name Like "USys*") Then
' Cycle through all fields in the table
For Each fld In td.Fields
If fld.Type = dbText Then
For Each code In arCharCodes
strFld = "[" & fld.Name & "]"
strSQL = "UPDATE [" & td.Name & "] " & _
"SET " & strFld & " = Replace(" & strFld & ", Chr(" & code & "), '. ') " & _
"WHERE " & strFld & " LIKE '*" & Chr(code) & "*'"
Debug.Print strSQL
db.Execute strSQL
Debug.Print "Updated " & db.RecordsAffected & " records."
Next code
End If
Next fld
End If
Next td
End Sub
If this still gives errors, check the specific SQL (Ctrl+g shows the output of Debug.Print) - what column data type does it want to update?
I'm having a problem getting a recordset to run from a query I created in an MS Access 2010 database. here is t he code I want to run:
Private Sub Command192_Click()
Dim recs As String
Dim param As Integer
Dim rs As Recordset
Set rs = CurrentDb.OpenRecordset("UnitRec_Qry", dbOpenDynaset)
With rs
.MoveLast
.MoveFirst
While Not .EOF
recs = recs & vbNewLine & !Spara & " - " & !Rec
.MoveNext
Wend
End With
MsgBox (recs)
End Sub
What this should output is a message box with a number of records from the query in a list. I do this so I can gather this and a number of other records into a text file for copying and pasting into a separate system. At the moment, I'm running this code so I can place it all into a string variable.
My problem is that I'm getting the dreaded "Too Few parameters expected 1" error.
The query works, I've saved it into the database and tested it and I get the expected results.
I tried running the recordset with SQL:
Set rs = CurrentDb.OpenRecordset("SELECT UnitRecommend_tbl.URecID, UnitRecommend_tbl.Spara," _
& " UnitRecommend_tbl.Rec, UnitRecommend_tbl.SvyID" _
& " FROM UnitRecommend_tbl" _
& " WHERE ((UnitRecommend_tbl.SvyID) = [Forms]![SurveyRegister_frm]![SurveyID])" _
& " ORDER BY UnitRecommend_tbl.Spara;", dbOpenDynaset)
I get the same error
I ran it again but removed the "WHERE" statement and the code ran just fine, but gave me every record in the table. Not what I wanted.
So, the fields are OK because the data runs. When I debug the text the parameter in the SQL does show up as the right parameter, in this case, the number 4 which is an integer.
So I'm at a loss here, I've searched through the other posts here and I have tried these possible solutions (unless I missed something).
I also tried using dbopensnapshot as well, still no joy. Wondering if I'm using the right code here now.
Any help would be great.
Cheers
A parameter like [Forms]![SurveyRegister_frm]![SurveyID] doesn't get evaluated automatically if you open a recordset in VBA.
Use this function:
Public Sub Eval_Params(QD As DAO.QueryDef)
On Error GoTo Eval_Params_Err
Dim par As DAO.Parameter
For Each par In QD.Parameters
' This is the key line: Eval "evaluates" the form field and gets the value
par.Value = Eval(par.Name)
Next par
Eval_Params_Exit:
On Error Resume Next
Exit Sub
Eval_Params_Err:
MsgBox Err.Description, vbExclamation, "Runtime-Error " & Err.Number & " in Eval_Params"
Resume Eval_Params_Exit
End Sub
with a QueryDef object like this:
Dim QD As QueryDef
Dim RS As Recordset
Set QD = DB.QueryDefs("UnitRec_Qry")
Call EVal_Params(QD)
Set RS = QD.OpenRecordset(dbOpenDynaset)
Alternatively, you can run it with SQL in the VBA code by moving the parameter outside of the SQL string:
Set rs = CurrentDb.OpenRecordset("SELECT UnitRecommend_tbl.URecID, UnitRecommend_tbl.Spara," _
& " UnitRecommend_tbl.Rec, UnitRecommend_tbl.SvyID" _
& " FROM UnitRecommend_tbl" _
& " WHERE ((UnitRecommend_tbl.SvyID) = " & [Forms]![SurveyRegister_frm]![SurveyID] & ")" & _
& " ORDER BY UnitRecommend_tbl.Spara;", dbOpenDynaset)
I need some help. When i run the below query I get no results back if i include the Pkg number part of the where. When i run the query in Access it works fine.
example of vars
package number 1_282
Rptdt 201301
Dim db As Database 'generic database object
Dim rst As Recordset 'this is going to hold the query result
Set db = CurrentDb
Dim PKG As Double
Dim rptDT As Double
Dim wireDT As Date
Set rst = db.OpenRecordset("SELECT Max(tbl_Revision.Revision_Number) as Revision_Number FROM tbl_Revision" & _
" where (tbl_Revision.RUN_YR_MO=" & rptDT & ")" & _
" and (tbl_Revision.Package_Number=" & PKG & ")")
getRevision = rst!Revision_Number + 1
The PKG cant be a Double if you want 1_282 to work. So make it a string.
Also you will have to add quotes :
" where (tbl_Revision.RUN_YR_MO='" & rptDT & "')" & _