I have some code that exports queries and saves the document as a rich-text file:
DoCmd.OutputTo acReport, "rptEvents", "RichTextFormat(*.rtf)", "C:\SARPCCO_Database\SARPCCO_Report.rtf"
How can I open the saved document wih the same export button?
The full code behind this button is:
Private Sub CommandExport_Click()
On Error GoTo Err_CommandExport_Click
Dim db As Database
Dim qdf As QueryDef
Dim strSql As String
'Dim rsCriteria As Recordset
Dim strWhere As Recordset
Set db = CurrentDb
Set strWhere = db.OpenRecordset("qryEvents", dbOpenDynaset)
'*** the first record in the Criteria table ***
strWhere.MoveFirst
'*** loop to move through the records in Criteria table
'Do Until strWhere.EOF
'*** create the Select query based on
' the first record in the Criteria table
strSql = "SELECT * FROM qryEvents WHERE "
strSql = strSql & "[Event_ID] = " & strWhere![Event_ID]
'*** delete the previous query
'db.QueryDefs.Delete "qryEvents2"
'Set qdf = db.CreateQueryDef("qryEvents2", strSql)
DoCmd.OutputTo acReport, "rptEvents", "RichTextFormat(*.rtf)", "C:\SARPCCO_Database\SARPCCO_Report.rtf"
Documents.Open Filename:="C:\SARPCCO_Database\SARPCCO_Report.rtf", ReadOnly:=False
strWhere.MoveNext
'Loop
Exit_CommandExport_Click:
Exit Sub
Err_CommandExport_Click:
MsgBox "The file SARPCCO_Report you want to export to doest not exists." & vbCrLf & vbLf & _
"Please, ensure the file is in the right place before attempting to export your report", vbExclamation + vbOKOnly, "Report exporting error"
Resume Exit_CommandExport_Click
End Sub
Thank you GOOGLE, I found a working code:
Dim WordApp As Object
Dim WordDoc As Object
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Open(Filename:="C:\MyFiles\Test.rtf", ReadOnly:=False)
WordApp.Visible = True
'do your stuff
Set WordDoc = Nothing
Set WordApp = Nothing
Append a True for AutoOpen:
DoCmd.OutputTo acReport, "rptEvents", "RichTextFormat(*.rtf)", "C:\SARPCCO_Database\SARPCCO_Report.rtf", True
Related
I'm trying to write some VBA to export filtered records from a subform. I've found a number of post related to this issue and I've cobbled the code below from those post.
When I run it I get a run-time error saying:
the Object '__temp' already exist.
When I click debug it highlights the line
Set qrydef = db.CreateQueryDef(strTempQryDef, strSQL)
Thank you for you help.
Private Sub ExportSubform()
Dim db As dao.Database
Dim qrydef As dao.QueryDef
Dim strSQL As String
Dim bolWithFilterOn As Boolean
Dim strTempQryDef As String
Dim strRecordSource As String
strTempQryDef = "__temp"
bolWithFilterOn = me.subsearch_frm.Form.FilterOn
strRecordSource = me.subsearch_frm.Form.RecordSource
If InStr(strRecordSource, "SELECT ") <> 0 Then
strSQL = strRecordSource
Else
strSQL = "SELECT * FROM [" & strRecordSource & "]"
End If
' just in case our sql string ends with ";"
strSQL = Replace(strSQL, ";", "")
If bolWithFilterOn Then
strSQL = strSQL & _
IIf(InStr(strSQL, "WHERE ") <> 0, " And ", " Where ") & _
me.subsearch_frm.Form.Filter
End If
Set db = CurrentDb
'create temporary query
Set qrydef = db.CreateQueryDef(strTempQryDef, strSQL)
db.QueryDefs.Append qrydef
Set qrydef = Nothing
DoCmd.TransferSpreadsheet TransferType:=acExport, _
SpreadsheetType:=acSpreadsheetTypeExcel12Xml, _
TableName:=strTempQryDef, _
FileName:=Replace(CurrentProject.Path & "\", "\\", "\") & strTempQryDef & ".xlsx"
' Delete the temporary query
db.QueryDefs.Delete strTempQryDef
Set db = Nothing
End Sub
Per the documentation:
If the object specified by name is already a member of the QueryDefs collection, a run-time error occurs.
As such, you should delete the temporary query before attempting to create it. To do this, you could use code along the lines of the following:
On Error Resume Next
DoCmd.DeleteObject acQuery, strTempQryDef
On Error GoTo 0
Also, per the documentation:
In a Microsoft Access workspace, if you provide anything other than a zero-length string for the name when you create a QueryDef, the resulting QueryDef object is automatically appended to the QueryDefs collection.
As such, you don't need this line:
db.QueryDefs.Append qrydef
This code below is giving me a runtime error stating the table is already open by another user, when I am trying to execute a delete query. It is only giving me this error on this delete query when I am trying to run it strictly through vba, but if i try to run it manually It works as it is designed too? Also, if I comment out this delete query I end up having no issues?
Private Sub Command27_Click()
Dim dbs As dao.Database
Dim Response As Integer
Dim strSQL As String
Dim Query1 As String
Dim LTotal As String
Dim Excel_App As Excel.Application 'Creates Blank Excel File
Dim strTable As String ' Table in access
LTotal = DCount("*", "tbPrintCenter03 RequestedToPrint", "Assigned= True")
Select Case MsgBox("There are (" & LTotal & ") record(s) selected to be
printed." & vbNewLine & " Do you wish to continue?", vbQuestion + vbYesNo,
"Mark as Printed?")
'If yes is Clicked
Case vbYes
Assigned = True 'Changes from false to True
Assigned_User52 = fOSUserName 'Assigns their 5&2
Assigned_Date = Date + Time 'Gets timestamp
'Updates the Global Table in SQL
DoCmd.SetWarnings False
DoCmd.OpenQuery "Qry_UpdateMasterfrom04", acViewNormal, acEdit
DoCmd.OpenQuery "Qry_AppendTo05Que", acViewNormal, acEdit
DoCmd.OpenQuery "Qry_DeletePrinted", acViewNormal, acEdit
''Run-Time error 3006 is happening on this line of code
DoCmd.Close acForm, "tbPrintCenter_Main", acSaveYes 'Save and Close
DoCmd.OpenForm ("tbPrintCenter_Main") 'Opens Form
'-------------------------------------------------------------------------------
'Reference Only
' DoCmd.GoToRecord , , acNext 'Goes to next record
' ' DoCmd.GoToRecord , , acNext
'-------------------------------------------------------------------------------
strTable = "tbPrintCenter05Que" 'Access Table I am trying to copy
Set Excel_App = CreateObject("Excel.Application")
Set dbs = CurrentDb
Dim rs As dao.Recordset
Set rs = dbs.OpenRecordset(strTable)
Excel_App.Visible = True
Dim wkb As Excel.Workbook
Set wkb = Excel_App.Workbooks.Add
Dim rg As Excel.Range
Dim i As Long
' Add the headings
For i = 0 To rs.Fields.Count - 1
wkb.Sheets(1).Cells(1, i + 1).Value = rs.Fields(i).Name
Next i
Set rg = wkb.Sheets(1).Cells(2, 1)
rg.CopyFromRecordset rs
' make pretty
rg.CurrentRegion.EntireColumn.AutoFit
DoCmd.OpenQuery "Qry_DeleteRecordsFrom05", acViewNormal, acEdit
Response = MsgBox("Updated to an assigned user!", vbInformation + vbOKOnly)
'MsgBox Update Complete
DoCmd.SetWarnings True
Exit Sub
'If no is clicked
Case vbNo
Response = MsgBox("No actions are performed!", vbInformation)
Exit Sub
End Select
End Sub
Following the link provided you will see the code I am using bits and pieces ofr on. Any advice?
https://stackoverflow.com/a/58732371/10226211
I have a database and I would like some VBA code to enable me to email specific pages of an Access report via Outlook.
For example, if I want to attach page 10 to 20 from a report.
I know how to attach a report to an email. This is my code that working properly, but I want to send specific page from Access Report.
Thanks in advance.
Dim olApp As Object
Dim olItem As Variant
Dim rec As Recordset
Dim db As Database
Dim fileName As String, todayDate As String
Set db = CurrentDb
todayDate = Format(Date, "MMDDYYYY")
fileName = Application.CurrentProject.path & "\Invoice_" & todayDate & ".pdf"
DoCmd.OutputTo acOutputReport, "rptInvoice", acFormatPDF, fileName, False
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(0)
olItem.display
olItem.To = Nz(rec![EmailPrimaryContact])
olItem.Subject = ""
olItem.Attachments.Add fileName
olItem.htmlBody = "Dear & " < br > " "
olItem.display
Set olItem = Nothing
Set rec = Nothing
Assuming you have Adobe as a printer option, consider DoCmd.PrintOut after adjusting the report's Printer property:
Use below subroutine to find Adobe printer
Sub Printers()
Dim prtDefault As Printer
For Each prtDefault In Application.Printers
Debug.Print prtDefault.DeviceName
Next prtDefault
Set prtDefault = Nothing
End Sub
Adjusted VBA (replaces DoCmd.OutputTo...)
Sub OutlookEmailModule()
...
DoCmd.OpenReport "rptInvoice", acViewReport ' OPEN REPORT
Reports("rptInvoice").Printer = Application.Printers("Adobe PDF") ' ADJUST PRINTER
DoCmd.PrintOut acPages, 7, 10 ' SUBSET PAGES
' PROMPTS YOU TO SAVE DOCUMENT AS fileName
DoCmd.Close acReport, acSaveNo ' CLOSE W/O SAVING
...
olItem.Attachments.Add fileName ' USE SAME FILE AS ABOVE
...
End Sub
I am new to Excel VBA. I have a user form in which I am trying to populate names of those employees who are AMO. I have a database called Ofc. Under which I have a table EmployeeDetails. Primary key is PeoplesoftId.
Here is the structure and the contents of the Employee table:
PeoplesoftId Nameofemployee RacifId Employeeid Designation
43243309 Maddala V43309 99651823 AMO
43243310 Abhishek A43301 99651824 AMO
43243311 Atanu A43311 99651825 MO
43243312 Rajiv R43312 99651826 CSE
This is the code I've written so far:
Dim cnn As ADODB.Connection 'dim the ADO collection class
Dim rs As ADODB.Recordset 'dim the ADO recordset class
Dim dbPath As String
Dim SQL As String
Dim i As Integer
Dim var
'add error handling
On Error GoTo errHandler:
'Disable screen flickering.
Application.ScreenUpdating = False
dbPath = "E:\office_hsbc\ofc.accdb"
var = "AMO"
Set cnn = New ADODB.Connection ' Initialise the collection class variable
cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
cnn.Open
SQL = "SELECT Nameofemployee FROM EmployeeDetails where Designation= '" & var & "'"
Set rs = New ADODB.Recordset 'assign memory to the recordset
rs.Open SQL, cnn
If rs.EOF And rs.BOF Then
rs.Close
cnn.Close
'clear memory
Set rs = Nothing
Set cnn = Nothing
'Enable the screen.
Application.ScreenUpdating = True
MsgBox "There are no records in the recordset!", vbCritical, "No Records"
Exit Sub
End If
For i = 0 To rs.Fields.Count - 1
comboamo.AddItem rs.Fields(i).Value, i
Next
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
MsgBox "Congratulation the data has been successfully Imported", vbInformation, "Import successful"
'error handler
On Error GoTo 0
Exit Sub
errHandler:
'clear memory
Set rs = Nothing
Set cnn = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Import_Data"
You need to move through each record in the recordset. Currently you are trying to read all of the fields from a single record but your query only returns one field. Try this instead:
MsgBox "There are no records in the recordset!", vbCritical, "No Records"
Exit Sub
End If
i = 0
Do Until rs.EOF
comboamo.AddItem rs.Fields("Nameofemployee").Value, i
rs.MoveNext
i = i + 1
Loop
rs.Close
I have a table and a text file. Once the records in the table copied into textfile, the records will be deleted. But the table are still in used and will be inserted with a new records from time to time(by another program). I what to do checking on How to make sure that if there are no records in the table, the program will never copy into textfile.
Any solution, or references are very thankful. Thank you very much. Im testing in WSH and using MSSQL Server 2005.
'call functions
call CopyFile()
call tblDelete()
Sub tblDelete()
Dim sql1
sql1 = "DELETE from tblOutbox"
rs = conn.Execute(sql1)
End Sub
Sub CopyFile
'set the sql command
cmd.CommandText = "SELECT * FROM tblOutbox"
cmd.CommandType = 1 ''# adCmdText Command text is a SQL query
Dim rs : Set rs = cmd.Execute
'create obj for the FileSystem
Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objFile, objFolder
Dim strDir, strFile
strDir = "c:\"
strFile = "\newFile.txt"
'check that the strDirectory folder is exist
If objFSO.FolderExists(strDir) Then
Set objFolder = objFSO.GetFolder(strDir)
Else
Set objFolder = objFSO.CreateFolder(strDirectory)
WScript.Echo "Just created " & strDir
End If
If objFSO.FileExists(strDir & strFile) Then
Set objFolder = objFSO.GetFolder(strDir)
Else
Set objFile = objFSO.CreateTextFile(strDir & strFile)
Wscript.Echo "Just created " & strDir & strFile
End If
Set objFile = Nothing
Set objFolder = Nothing
'open files and copy into
Dim objtextStream : Set objtextStream = objFSO.OpenTextFile(strDir & strFile, 8, True)
Do Until rs.EOF
objtextStream.Write rs("id") & ", "
objtextStream.Write rs("ip") & ", "
objtextStream.Write rs("msg") & ", "
objtextStream.WriteLine rs("date")
rs.MoveNext
Loop
objTextStream.WriteLine
objTextStream.WriteLine "Report Generate at " & Now
objTextStream.WriteLine "--------------------------------------------"
objtextStream.Close
rs.Close
End Sub
You could put
If rs.RecordCount > 0 Then
exit sub
End If
before
Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objFile, objFolder
i.e. Don't execute any of the statements, if there are no records.
Can you set your code up in a format such as the following, in which you delay opening the output file until after you have fired your query and retrieved at least one response:
Set up SQL statement
Execute SQL query
init bFirstRecord as true
Loop over results
if bFirstRecord
check folder and file existence, create as necessary
open output file
bFirstRecord = false
end if
write record to output
End Loop
Close up files, etc