I am trying to automate the exporting of a formatted text file based on a query.
I have created a saved export.
Private Sub Export_Click()
Dim strFileName As String
Dim lFileName As Long
Dim strCurrentDate As String
Dim dtCurrentDate As Date
Dim strDir As String
Dim strFullName As String
Dim strExportSpec As String
Dim strQueryName As String
strDir = "C:\Users\Owner\Google Drive\2021\Job Submittal\"
strCurrentDate = InputBox("Enter Week Date", "Enter Week Date")
lFileName = InputBox("Enter Week Number", "Enter Week Number")
strFileName = "qryUnEmployment_" & strCurrentDate & "_" & lFileName
strFullName = strDir & strFileName & ".txt"
strExportSpec = "ExportqryUnemployment"
strQueryName = "qryUnEmployment"
'Does not recognize spec
' DoCmd.TransferText acExportDelim, strExportSpec, strQueryName, strFullName, True
DoCmd.TransferText acExportDelim, , strQueryName, strFullName, True
End Sub
If I run the current code the file does export but with no formatting.
I have to have the formatting with the columns lined up
Related
I am trying to import exported objects from another database. The file extension is vba. I have created a loop to go through all the objects. My loop does go through all the files properly. The loop does import a module as Module 1 for the first file. I want to rename the module from module 1 to the previous module name.
I am working with MS Access office 365.
Sub LoopThroughFiles2()
Dim strFile As String
Dim strNewFile As String
Dim strPath As String
Dim strNewPath As String
Dim strDBName As String
Dim strModName As String
strDBName = Application.CurrentProject.Name
strPath = ("C:\Users\Parents\Google Drive\Access Files\File7\")
strFile = Dir(strPath & "*")
Do While Len(strFile) > 0
Debug.Print strFile
Debug.Print strPath
strNewFile = Replace(strFile, ".vba", ".txt", 1, , vbTextCompare)
Debug.Print strNewFile
Name strPath & strFile As strPath & strNewFile
strNewPath = strPath & strFile
strModName = Replace(strNewFile, ".txt", "")
Debug.Print strModName
VBE.ActiveVBProject.VBComponents.Import strNewPath
VBProj.VBComponents("Module 1").Name = strModName 'error 424
DoCmd.Rename strModName, acModule, "Module1" 'error 7874
Loop
End Sub
You can't change the name directly, but you can change a property instead, like this:
VBE.ActiveVBProject.VBComponents("Module 1").Properties("Name").Value = strModName
I'm using the code below to link my bank-end database to the front-end. It works fine without having a password on the back-end DB. How do I use the same code with a password protected back-end file. NOTE: The following code is obtained from [Stackoverflow question][1]
[1]: https://stackoverflow.com/questions/3315306/how-can-a-relative-path-specify-a-linked-table-in-access-2007
Private Sub Form_Load()
Dim strOldConnect As String
Dim strNewConnect As String
Dim intSlashLoc As Integer
Dim intEqualLoc As Integer
Dim strConnect As String
Dim strFile As String
Dim strCurrentPath As String
strCurrentPath = CurrentProject.path
Dim tblDef As TableDef
Dim tblPrp As Property
For Each tblDef In CurrentDb.TableDefs
Debug.Print tblDef.Name
If tblDef.Connect & "." <> "." Then
strOldConnect = tblDef.Connect
intEqualLoc = InStr(1, strOldConnect, "=", vbTextCompare)
strConnect = Left(strOldConnect, intEqualLoc)
intSlashLoc = InStrRev(strOldConnect, "\", -1, vbTextCompare)
strFile = Right(strOldConnect, Len(strOldConnect) - intSlashLoc)
strNewConnect = strConnect & strCurrentPath & "\" & strFile
tblDef.Connect = strNewConnect
tblDef.RefreshLink
End If
Next tblDef
End Sub
The whole connection string for Access Microsoft ACE OLEDB 12.0 is:
Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\myFolder\myAccessFile.accdb; Jet OLEDB:Database Password=MyDbPassword;
See this link for reference https://www.connectionstrings.com/access/
In your case this would to the trick:
tblDef.Connect = "PWD=" & MyPassword & ";DATABASE=" & YourDatabasePath
I found a workaround myself and would like to share it, thank you.
Public Function DBconnect()
Dim Password As String
Dim FileName As String
Dim CurrentConnection As String
Dim AccessConnect As String
Dim NewConnection As String
Dim CurrentPath As String
Dim CurrentLocationEnd As Integer
AccessConnect = "MS Access;PWD=password;DATABASE="
Password = "password"
CurrentPath = CurrentProject.Path
Dim tblDef As TableDef
Dim tblPrp As Property
For Each tblDef In CurrentDb.TableDefs
Debug.Print tblDef.Name
If tblDef.Connect & "." <> "." Then
CurrentConnection = tblDef.Connect
CurrentLocationEnd = InStrRev(CurrentConnection, "\", -1, vbTextCompare)
FileName = Right(CurrentConnection, Len(CurrentConnection) - CurrentLocationEnd)
NewConnection = AccessConnect & CurrentPath & "\" & FileName
tblDef.Connect = NewConnection
tblDef.RefreshLink
End If
Next tblDef
End Function
I have a table that contains a paths of multi pdfs file...now I need a VBA code to merge all these files to a single pdf file.
Notice:-the number of pdfs files to be merged varies from time to time.
Sub Combine_PDFs_Demo()
Dim i As Integer 'counter for records
Dim x As Integer
Dim strNPDF As String
Dim bSuccess As Boolean
Dim DB As Database
Dim RS As Recordset
Set DB = CurrentDb
Set RS = DB.OpenRecordset("SELECT[paths] from scantemp ")
strNPDF = CurrentProject.Path & "\request_pic\" & (request_no) & ".pdf"
RS.MoveLast
DB.Recordsets.Refresh
i = RS.RecordCount
RS.MoveFirst
Dim strPDFs() As String
ReDim strPDFs(0 To i)
strPDFs(0) = RS![paths]
RS.MoveNext
For i = 1 To i - 1
strPDFs(i) = RS![paths]
bSuccess = MergePDFs(strPDFs, strNPDF)
Next i
If bSuccess = False Then MsgBox "Failed to combine all PDFs", vbCritical, "Failed to Merge PDFs"
DoCmd.SetWarnings False
DoCmd.RunSQL "delete from scantemp" 'delete all paths from table scantemp after converted it to pdf
DoCmd.SetWarnings True
RS.Close
Set RS = Nothing`enter code here`
public Function MergePDFs(arrFiles() As String, strSaveAs As String) As Boolean
Dim objCAcroPDDocDestination As Acrobat.CAcroPDDoc
Dim objCAcroPDDocSource As Acrobat.CAcroPDDoc
Dim i As Integer
Dim iFailed As Integer
On Error GoTo NoAcrobat:
'Initialize the Acrobat objects
Set objCAcroPDDocDestination = CreateObject("AcroExch.PDDoc")
Set objCAcroPDDocSource = CreateObject("AcroExch.PDDoc")
'Open Destination, all other documents will be added to this and saved with
'a new filename
objCAcroPDDocDestination.Open (arrFiles(LBound(arrFiles))) 'open the first file
'Open each subsequent PDF that you want to add to the original
'Open the source document that will be added to the destination
For i = LBound(arrFiles) + 1 To UBound(arrFiles)
objCAcroPDDocSource.Open (arrFiles(i))
If objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0) Then
MergePDFs = True
Else
'failed to merge one of the PDFs
iFailed = iFailed + 1
End If
objCAcroPDDocSource.Close
Next i
objCAcroPDDocDestination.save 1, strSaveAs 'Save it as a new name
objCAcroPDDocDestination.Close
Set objCAcroPDDocSource = Nothing
Set objCAcroPDDocDestination = Nothing
NoAcrobat:
If iFailed <> 0 Then
MergePDFs = False
End If
On Error GoTo 0
End Function
This uses a list of PDF or PS files to create one PDF. Sorry it's in VB.net and I don't really have time to convert. But it illustrates the concept if you can wade through it. Basically you write the options and file names to a text file then use that file as an argument to Ghostscript.
Private Shared Sub ConvertToPDF(ByVal PSPathFileList As List(Of String), _
ByVal PDFPathName As String, _
ByVal WaitForExit As Boolean, ByVal DeletePS As Boolean)
'check that all files exist
PSPathFileList.ForEach(AddressOf CheckFiles)
'check old pdf file
If IO.File.Exists(PDFPathName) Then
Throw New ApplicationException( _
"PDF cannot be created. File already exists: " & PDFPathName)
End If
'convert engine
Dim myProcInfo As New ProcessStartInfo
myProcInfo.FileName = DanBSolutionsLocation & "Misc\GhostScript\GSWIN32C.EXE"
Debug.Print(myProcInfo.FileName)
'write file names to text file as the list can be very long
Dim tempPath As String = IO.Path.GetDirectoryName(PSPathFileList.Item(0))
Dim fiName2 As String = tempPath & IO.Path.GetFileNameWithoutExtension(PDFPathName) & ".txt"
Dim ft As New StreamWriter(fiName2)
ft.WriteLine("-sDEVICE=pdfwrite -q -dSAFER -dNOPAUSE -sOUTPUTFILE=""" & PDFPathName & """ -dBATCH ")
For i As Long = 0 To PSPathFileList.Count - 1
ft.WriteLine(Chr(34) & PSPathFileList.Item(i) & Chr(34))
Next
ft.Close()
'set args to text file
myProcInfo.Arguments = """#" & fiName2 & """"
'set up for output and errors
myProcInfo.UseShellExecute = False
myProcInfo.RedirectStandardOutput = True
myProcInfo.RedirectStandardError = True
Debug.Print(myProcInfo.Arguments)
'do the conversion
Dim myProc As Process = Process.Start(myProcInfo)
Debug.Print(myProc.StandardOutput.ReadToEnd)
Debug.Print(myProc.StandardError.ReadToEnd)
If WaitForExit Then
'wait for finish; (no more than 60 seconds)
myProc.WaitForExit(60000)
'delete PS
If DeletePS Then
PSPathFileList.ForEach(AddressOf DeleteFiles)
End If
End If
End Sub
Here's VBA code for a single PS to PDF. So between the VB.net above and this below hopefully you can salvage something useful.
Private Sub printToPdfDemo()
'verify printer setup
'be sure to install the PsPrinterInstall module
Call PSPrinterSetup
Dim svPsFileName As String
Dim svPDFName As String
'define names
svPsFileName = "C:\Temp\Input 1.ps"
svPDFName = "C:\Temp\Output 1.PDF"
'save current printer
Dim PrinterInUse As String
PrinterInUse = Application.ActivePrinter
'print to PS
'If Fso.FileExists(svPsFileName) Then Call Fso.DeleteFile(svPsFileName)
Worksheets(1).PrintOut ActivePrinter:=PSPrinterName, PrintToFile:=True, _
PrToFileName:=svPsFileName
'revert to saved printer name
Application.ActivePrinter = PrinterInUse
'convert
Call ConvertToPDF(svPsFileName, svPDFName)
End Sub
Sub ConvertToPDF(ByVal svPsFileName As String, ByVal svPDFName As String)
Dim fso As New FileSystemObject
'Dim Fso: Set Fso = CreateObject("Scripting.FileSystemObject")
Dim folGS As Folder
Dim lcCmd As String
'check inputs
If svPsFileName = "" Or svPDFName = "" Then
Call MsgBox("PS file name or PDF file name is blank in ""ConvertToPDF"" macro", vbExclamation, "Error! Missing Inputs")
Exit Sub
End If
'check file
If Not fso.FileExists(svPsFileName) Then
Call MsgBox(svPsFileName & " file is not found", vbExclamation, "Error! Missing File")
Exit Sub
End If
'check variable
If DanBSolutionsLocation = "" Then DanBSolutionsLocation = GetDanBSolutionsLocation
'delete old file
If fso.FileExists(svPDFName) Then Call fso.DeleteFile(svPDFName)
'get files
Set folGS = fso.GetFolder(DanBSolutionsLocation & "Misc\GhostScript\") 'S:\DanB Solutions\Misc\GhostScript\GSWIN32C.EXE
'GS command
lcCmd = folGS.ShortPath & "\GSWIN32C.EXE " & _
"-q -dNOPAUSE -I" & folGS.ShortPath & "\lib;./fonts " & _
"-sFONTPATH=./fonts -sFONTMAP=" & folGS.ShortPath & "\lib\FONTMAP.GS " & _
"-sDEVICE=pdfwrite -sOUTPUTFILE=" & """" & svPDFName & """" _
& " -dBATCH " & """" & svPsFileName & """"
'convert
Debug.Print lcCmd
Call ShellWait(lcCmd)
'delete PS
If fso.FileExists(svPDFName) Then fso.DeleteFile (svPsFileName)
End Sub
I want to create some VBA code to open an existing Excel workbook, transfer the query to a new sheet and save the file with todays date and time. So far this is the code I
Private Sub cmd_planning_report_Click()
Dim ExportNumber As String
Dim ExportFileName As String
Dim ProjectPath As String
Dim FolderPath As String
Dim FilePath As String
Dim TemplatePath As String
ProjectPath = CurrentProject.Path
FolderPath = "Report_Templates"
FilePath = "Template.xlsx"
TemplatePath = ProjectPath & "\" & FolderPath & "\" & FilePath
ExportNumber = Format(Now(), "YYYYMMDD_HHMMss")
ExportFileName = "my_report_" & ExportNumber & ".xlsx"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "A1_Report", TemplatePath, True
End Sub
Which works as the query is exported to Template.xlsx but I would like it to save the file as ExportFileName
Looks like you just need this twist:
ProjectPath = CurrentProject.Path
FolderPath = "Report_Templates"
ExportNumber = Format(Now(), "YYYYMMDD_HHMMss")
ExportFileName = "my_report_" & ExportNumber & ".xlsx"
TemplatePath = ProjectPath & "\" & FolderPath & "\" & ExportFileName
You could rename the file once it is saved in the template with
NAME TemplatePath AS ExportFileName
Or make a copy of the file with the new name.
Dim fso As MyObject
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
fso.CopyFile TemplatePath, ExportFileName
I want to write all the records in a query to an e-mail.
This writes the first record in the query.
MyBodyText = MailList("AccountName") & " - " & MailList("ExpirationDate")
I know I need some kind of loop.
MailList is defined as follows
Set MailList = db.OpenRecordset("qryDateEmail")
Option Compare Database
Option Explicit
Public Function ExpirationDate()
Dim strSQL
Dim db As DAO.Database
Dim MailList As DAO.Recordset
Dim MyOutlook As Outlook.Application
Dim MyMail As Outlook.MailItem
Dim Subjectline As String
Dim BodyFile As String
Dim fso As FileSystemObject
Dim MyBody As TextStream
Dim MyBodyText As String
Dim MyDecision As String
Dim strReportName As String
Dim strEnroll As String
Dim strWho As String
Dim strEmail As String
Set fso = New FileSystemObject
Set MyOutlook = New Outlook.Application
Set db = CurrentDb()
Set MailList = db.OpenRecordset("qryDateEmail")
Subjectline$ = "Expiration Date" & " " & Date
Set MyMail = MyOutlook.CreateItem(olMailItem)
Do While Not MailList.EOF
MyBodyText = MailList("AccountName") & " - " & MailList("ExpirationDate")
MailList.MoveNext
Loop
MyMail.To = "" & ""
MyMail.CC = CurrentUser() & ""
MyMail.Subject = Subjectline$
MyMail.Body = MyBodyText
MyMail.Display
strEmail = Now()
strWho = CurrentUser()
Set MyMail = Nothing
Set MyOutlook = Nothing
End Function
You could loop through the recordset, adding those values from each row to your body text.
Untested air code:
With MailList
Do While Not .EOF
MyBodyText = MyBodyText & !AccountName & _
" - " & !ExpirationDate & vbCrLf
.MoveNext
Loop
End With
Now I see you've added similar code to your question. The problem is that code overwrites the value of MyBodyText each time through the loop. Append to MyBodyText each time instead of replacing the text ...
MyBodyText = MyBodyText & "new text"
instead of ...
MyBodyText = "new text"