I've got the attached query, which shows several rows (there is more data) but only 2 email address. I would like to send the corresponding rows to their relevant email address. All these details change every week, and there will be more (and sometimes less) email addresses, so I need to keep the data coming from this form (rather than static addresses). I've tried making a report, and can manage to send that to the email address, but I get multiple forms/emails for this report. The query will show a lot of records, so this is not an acceptable solution.
Any help would be gratefully received.
EDIT - I've attached the tables which show the data. I just want to send each company their own few rows by any means possible. Please help :)
Thanks.
My Full code:
Dim rS As DAO.Recordset
Dim dbS As DAO.Database
Dim Filepath As String
Dim Folderpath As String
Dim oOutlook As Outlook.Application
Dim oEmailItem As MailItem
Set dbS = CurrentDb()
Set rS = dbS.OpenRecordset("Select DISTINCT email, [CompName], [MainContact] FROM q66NonConfirmedTimesheets")
Do While Not rS.EOF
myemail = rS!email
mycompname = rS!CompName
myMainContact = rS!MainContact
'My Email the report
Folderpath = "C:\Reports\"
Folderpath = Folderpath & "WeeklyTimesheet, " & [mycompname] & " - " & Format(date, "dd mmm yyyy") & ".pdf"
DoCmd.OpenReport "Rpt01UnconfirmedTimesheets", acViewPreview, , "email = '" & myemail & "'"
DoCmd.OutputTo acOutputReport, , "PDFFormat(*.pdf)", Folderpath, False
DoCmd.Close acReport, "Rpt01UnconfirmedTimesheets"
If oOutlook Is Nothing Then
Set oOutlook = New Outlook.Application
End If
Set oEmailItem = oOutlook.CreateItem(olMailItem)
With oEmailItem
.to = [myemail]
.Subject = "Unconfirmed Timesheets"
.Body = "Automatic email from my database"
.Attachments.Add Folderpath
.Display
End With
'End of my emailing report
rS.MoveNext
Loop
Set oEmailItem = Nothing
Set oOutlook = Nothing
Set rS = Nothing
Set dbS = Nothing
End Sub
and I've added into my "Onload" event on the Report:
Me.Filter = "[email]='" & myemail & "'"
You need to open a recordset in VBA that contains the unique email addresses.
Loop through the recordset, opening your report, filtering on the email address and emailing the report. Air code:
Dim rS as DAO.Recordset
Dim dbS as DAO.Database
Set dbS = CurrentDb()
Set rS = dbS.OpenRecordset("Select DISTINCT emailaddress FROM <yourquery>",DbOpenSnapshot)
Do While Not rS.EOF
<sometempvar> = rS!emailaddress
'your code to email filtered report using <sometempvar>'
rS.MoveNext
Loop
Set rS = Nothing
Set dbS = Nothing
You need to create a query to only return the emails and specify the query to return unique values only, there is an option for that in the query editor:
Related
I have been using this code for some time and it works. As a matter of fact it works with a basic query. It just does not work with my new Stored Procedure. I can run the stored procedure manually. in SSMS and get my results. I thought that the error was when I was not getting data back so I added the . . . If myRS1.EOF Then . . . still getting the 3704 runtime error.
Here is my Excel (2013) Code
Private Sub cmdOK_Click()
Dim myStartDate, myEndDate
Dim myInsuranceCode
Dim objAD, objUser
Dim myDisplayName, myLastRow
Dim myMessage, myStyle, myTitle, myResult
Dim mySQL As String
Dim myConn
Dim myCmd
Dim myRS1
Dim myRange, myNamedRange, myCheckRange As Range
Dim X, Y, z
Dim myPercent, myLowEnd, myHighEnd
Dim myValue1, myValue2, myValue3, myValue4, myValue5, myValue6, myValue7, myValue8
Dim myCheckValue
Dim myHeaderRow, myDataRow, myLastColumn
'SET THESE ACCORDING TO THE REPORT. THE FIRST TWO MIGHT NOT NEED ANY CHANGES
myHeaderRow = 2
myDataRow = 3
myLastColumn = 22
'SETUP DATABASE OBJECTS
Set myConn = New ADODB.Connection
Set myCmd = New ADODB.Command
Set myRS1 = New ADODB.Recordset
Application.StatusBar = True
Application.StatusBar = "Connecting to SQL Server"
'GET DATES FROM TEH FORM AND SET SQL STATEMENT
myStartDate = frmMain.txtStartDate
myEndDate = frmMain.txtEndDate
'RUN INSURANCE STORE PROCEDURE
'SEPERATE THE INSURANCE CODE WITH A |
myInsuranceCode = "S19|S22"
mySQL = "dbo.BMH_rpt_PATIENTS_INSURANCE_LISTING '" & myStartDate & "', '" & myEndDate & "', '" & myInsuranceCode & "'"
'mySQL = "SELECT * FROM dbo.BETHESDA_ADMIT_SOURCE"
'HIDE THE FORM
frmMain.Hide
'GET THE USER THAT IS SIGNED IN
Set objAD = CreateObject("ADSystemInfo")
Set objUser = GetObject("LDAP://" & objAD.UserName)
myDisplayName = objUser.DisplayName
'OPEN CONNECTIONS TO THE DATABASE
myConn.ConnectionString = "Provider=SQLOLEDB;Data Source=mySQLServer;Initial Catalog=myDatabaseName;User ID=user;Password=xxxxxxxx;Connection Timeout=300;"
myConn.Open
'SET AND EXECUTE SQL COMMAND
Set myCmd.ActiveConnection = myConn
myCmd.CommandText = mySQL
myCmd.CommandType = adCmdText
Application.StatusBar = "Running Stored Procedure " & mySQL
myCmd.CommandTimeout = 3000
'OPEN RECORDSET
Set myRS1.Source = myCmd
myRS1.Open
'CHECK TO MAKE SURE WE ARE NOT AT THE BOTTOM OF THE SHEET COULD MEAN THERE WAS NOT DATA LAST TIME.
'THIS SAME CODE WILL REPEAT FOR THE DATA TAB
'*********** DATA *************
'CHECK TO MAKE SURE THERE IS DATA
If myRS1.EOF Then <---- THIS IS THE LINE I AM GETTING THE ERROR
Cells(myDataRow, 1).Value = "No Data Qualifies"
myMessage = "No data qualifing for your request " & mySQL
myTitle = "No Data"
myStyle = vbCritical + vbOKOnly
myResult = MsgBox(myMessage, myStyle, myTitle)
Exit Sub
End If
'SELECT THE SHEET TO CLEAR OUT THE OLD data on DATA
'IF THIS IS NOT SET ON THE SEEHET IT WILL FAIL
Set myTable = Sheets("DATA").ListObjects("DATA")
If Cells(myDataRow, 1).Value <> "" Then
myTable.DataBodyRange.Rows.Delete
End If
'COPY THE DATA TO EXCEL
Application.StatusBar = "Copying the new data."
Sheets("DATA").Cells(myDataRow, 1).CopyFromRecordset myRS1
Cells(1048576, 1).Select
Selection.End(xlUp).Select
myLastRow = ActiveCell.Row
'Application.StatusBar = "Naming the new DATA range"
'ActiveWorkbook.Names.Add Name:=myNamedRange, RefersTo:=Range(Cells(myHeaderRow, 1), Cells(myLastRow, myLastColumn))
myTable.Resize Range(Cells(myHeaderRow, 1), Cells(myLastRow, myLastColumn))
End Sub
*** This is all the VBA Code now. It is failing on the myRS1.EOF line so none of the other code even runs.
As you can see I have two mySQL statements. The first one is not working, but the second one works no issue.
If I run the SP from SSMS or even take the mySQL that is generated it runs fine in SSMS.
Here is the SP
--EXAMPLE
-- dbo.BMH_rpt_PATIENTS_INSURANCE_LISTING '11/01/2020', '11/30/2020', 'S19|S22'
ALTER PROCEDURE [dbo].[BMH_rpt_PATIENTS_INSURANCE_LISTING]
#StartDate AS DATETIME,
#EndDate AS DATETIME,
#Insurance AS VARCHAR(MAX)
AS
/** GET THE INSURANCE CODES **/
SELECT VALUE
INTO #INSURANCE
FROM STRING_SPLIT(#Insurance, '|')
/** GET THE PATIENTS FOR THE LIST **/
SELECT vv.pt_id AS 'Patient Account',
vv.alt_med_rec_no AS 'MRN'
FROM smsdss.vst_v AS vv
WHERE vv.pyr_cd IN (SELECT * FROM #INSURANCE)
AND vv.start_full_date BETWEEN #StartDate AND #EndDate
AND vv.tot_bal_amt <> 0
Currently I have a table where the 'ID' field is automatically generated through a combination of multiple other fields. Example : ID = '2017_FileName_Chancellor'
Now I've been trying to figure out a way for me to rename this attachment to that ID (by possibly pressing a button in the form)without manually copy pasting the ID and renaming the attached file as that would be tedious when doing it for thousands of records. Is there anyway for me to do this? I have no knowledge in VBA so I could not tamper with that.
Providing a picture of my table might help https://i.imgur.com/gaTUCtk.png
To Change the Name of the Attachment in Access:
Private Sub Command15_Click()
Dim NewName As String
Dim NewNameWithExt As String
NewName = Me.TestID.Value
NewNameWithExt = NewName & ".txt"
DoCmd.RunSQL ("UPDATE TestTable SET TestAttachment.FileName = '" &
NewNameWithExt & "' WHERE TestID = " & NewName)
End Sub
To Change the Name of the File on the Desktop:
Private Sub Command0_Click()
Dim NewName As String
Dim OldName As String
Dim rs As Object
Dim strSQL As String
Set rs = CreateObject("ADODB.Recordset")
strSQL = "SELECT TestAttachment.FileName FROM TestTable WHERE TestID = 1"
rs.Open strSQL, CurrentProject.Connection, 1, 3
Do Until rs.EOF
OldName = rs.Fields(0)
NewName = CurrentDb.TableDefs("TestTable").Fields(0).Name
Name "C:\Users\TestUser\desktop\" & OldName As
"C:\Users\TestUser\desktop\" & NewName & ".TXT"
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
End Sub
I'm currently using a piece of code to display who is logged into our Access Database. It's a split database, with a backend and multiple frontends. I am currently using this code:
Private Sub btnShowUsers_Click()
'The User List Schema information requires this magic number. For anyone
'who may be interested, this number is called a GUID or Globally Unique
'Identifier - sorry for digressing
Const conUsers = "{947bb102-5d43-11d1-bdbf-00c04fb92675}"
Dim cnn As ADODB.Connection, fld As ADODB.Field, strUser As String
Dim rst As ADODB.Recordset, intUser As Integer, varValue As Variant
Set cnn = CurrentProject.Connection
Set rst = cnn.OpenSchema(Schema:=adSchemaProviderSpecific, SchemaID:=conUsers)
'Set List Box Heading
strUser = "Computer;UserName;Connected?;Suspect?"
Debug.Print rst.GetString
With rst 'fills Recordset (rst) with User List data
Do Until .EOF
intUser = intUser + 1
For Each fld In .Fields
varValue = fld.Value
'Some of the return values are Null-Terminated Strings, if
'so strip them off
If InStr(varValue, vbNullChar) > 0 Then
varValue = Left(varValue, InStr(varValue, vbNullChar) - 1)
End If
strUser = strUser & ";" & varValue
Next
.MoveNext
Loop
End With
Me!txtTotalNumOfUsers = intUser 'Total # of Users
'Set up List Box Parameters
Me!lstUsers.ColumnCount = 4
Me!lstUsers.RowSourceType = "Value List"
Me!lstUsers.ColumnHeads = False
lstUsers.RowSource = strUser 'populate the List Box
'Routine cleanup chores
Set fld = Nothing
Set rst = Nothing
Set cnn = Nothing
End Sub
This works, and it returns the laptop numbers of the users currently using the system, but in the 'Username' column it just says 'ADMIN'. Is there any way to get this to show their Windows username, ie their VBA.Environ("USERNAME")?
No, this is not possible.
This column shows the Access username, same as the Application.CurrentUser() method.
Unless you set up user-level security, add all users to the workgroup file, and start Access with a command-line parameter like
/User %username%
, the user name will always be "Admin".
The error says "The field is too small to accept the amount of data you attempted to add. Try inserting or pasting less data."
The database is supposed to pull in information from the Excel sheet that is passed through to it, and import the information into a recordset of the text field. However, the text field, somewhere down the line, has been limited to 50 characters. How can I change the maximum size of the text field? Thank you for any help
This is just part of the code, and the textfield I'm trying to make larger is "Idea_#", which is the last line of the code i posted
Sub Read_Recommendations()
On Error GoTo error_code
Dim FD As Office.FileDialog
Dim xlapp As Excel.Application
Dim xlsheet As Excel.Worksheet
Dim xlbook As Excel.Workbook
Dim db As Database
Dim rs As Recordset
Dim sql As String
Dim WP As String
Dim row As Integer
Dim File As String
Set db = CurrentDb
Set FD = Application.FileDialog(msoFileDialogOpen)
If FD.Show = True Then
File = FD.SelectedItems(1)
Set xlapp = CreateObject("Excel.Application")
Set xlbook = GetObject(File)
Set xlsheet = xlbook.Worksheets("Recommendation Approval Form")
Dim protection As Boolean
With xlsheet
'support unprotected worksheets
protection = xlsheet.ProtectContents
If protection Then xlsheet.Unprotect "veproject"
WP = .Range("WP_Number")
' Check that active WP and the WP of the uploading form is the same
' If WPs are different, awares users and prompts user whether or not to continue
Dim DifferentProject As String
If Not get_WP = WP Then
DifferentProject = MsgBox("You are uploading to the project with WP number: " & WP & " which is not the active project. Do you wish to continue?", vbYesNo)
If DifferentProject = 7 Then Exit Sub
End If
' Check that WP is correct by checking if it exists in the Record Information table
' delete the existing recomendations, we want to keep the most recent recomendations
' perhaps change this to a dialog in the future
sql = "DELETE * from tbl_recomendations WHERE WP_Number = '" & WP & "'"
db.Execute (sql)
row = 8
Set rs = db.OpenRecordset("tbl_recomendations")
Do While .Range("D" & row) <> ""
rs.AddNew
rs("WP_Number") = WP
rs("Idea_#") = (.Range("C" & row))
........
In Access, open tbl_recomendations in Design View. It sounds like the Field Size property for Idea_# is set at 50. You can change that up to 255.
If you need to store more than 255 characters in Idea_#, change its Data Type from Text to Memo.
I have put together a procedure to cycle through a table containing paths to text files and import them into the database.
Reason for procedure:
The reason for this is I am building a back end to many reporting databases that rely on nightly updated text files. Recently they changed the server name and file names for these files, so I'm trying to build something more reliable so I don't have to run through the link table wizard making sure all the data types are exactly the same as before.
Issue:
The issue I have is the With .edit .update isn't acting like I thought it should and updating the field 'Updated' in the table to today's date.
Here is the code. I'm still new to programming, so apologies.
Private Sub ImportAll()
' Loops through table containing paths to text files on network and imports
Dim ID As Integer
Dim netPath As String
Dim netDir As String
Dim netFile As String
Dim localTable As String
Dim activeTable As Boolean
Dim updatedTable As Date
Dim rst As DAO.Recordset
Set rst = CurrentDb.OpenRecordset("Tables")
Do Until rst.EOF
ID = rst.Fields("Table ID").Value
netDir = rst.Fields("Network Location").Value
netFile = rst.Fields("File Name").Value
localTable = rst.Fields("Local Table Name").Value
activeTable = rst.Fields("Active").Value
updatedTable = rst.Fields("Updated").Value
If activeTable = True And updatedTable <> Date Then
If ifTableExists(localTable) Then
On Error GoTo ImportData_Err
CurrentDb.Execute "DELETE * FROM " & localTable, dbFailOnError
netPath = netDir & netFile
DoCmd.TransferText acImportDelim, , localTable, netPath, True, ""
rst.Edit
updatedTable = Date
rst.Update
Else
netPath = netDir & netFile
DoCmd.TransferText acImportDelim, , localTable, netPath, True, ""
With rs
.Edit
.Fields("Updated") = Date
.Update
End With
End If
End If
rst.MoveNext
Loop
rst.Close
Set rst = Nothing
ImportData_Exit:
Exit Sub
ImportData_Err:
MsgBox Error$
Resume ImportData_Exit
End Sub
Thank you.
Where you have
With rs
You meant
With rst
Mistakes such as this can be caught by turning on Option Explicit. Option Explicit means that all variables must be declared.
See here: How do I force VBA/Access to require variables to be defined?