I want to autoback up my access database with the below code and it didn't work for me. I got an error "cannot find the input table or query "WinAutoBackup" Please view the picture. Also, did I use CurrentProject correctly?
[Function fMakeBackup() As Boolean
Dim Source As String
Dim Target As String
Dim retval As Integer
On Error GoTo sysBackup_Err
Source = CurrentDb.name
Target = "CurrentProject.path\backups\"
Target = Target & Format(Now, "yyyymmdd-hhnn") & ".accdb"
If DateDiff("d", DLookup("\[BackupDate\]", "WinAutoBackup", "\[BckID\]
=1"), Date) = 3 Then
retval = 0
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
retval = objFSO.CopyFile(Source, Target, True)
Set objFSO = Nothing
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE WinAutoBackup SET WinAutoBackup.BackupDate =
Date();"
DoCmd.SetWarnings True
MsgBox "Backup successfull. Next auto backup in 3 days"
Else
Exit Function
End If
sysBackup_Exit:
Exit Function
sysBackup_Err:
MsgBox Err.Description, , "sysBackup()"
Resume sysBackup_Exit
End Function][1]
Start with including:
Option Explicit
at the top of the module.
Then try with:
Function fMakeBackup() As Boolean
Dim objFSO As Object
Dim Source As String
Dim Target As String
Dim retval As Integer
' Disable error handling during development.
' On Error GoTo sysBackup_Err
Source = CurrentDb.Name
' Adjust if if backup folder is not \backups\.
Target = CurrentProject.Path & "\backups\"
Target = Target & Format(Now, "yyyymmdd-hhnn") & ".accdb"
' To run every time, use this line in plade of If DateDiff ...:
' If True Then
If DateDiff("d", DLookup("[BackupDate]", "[WinAutoBackup]", "[BckID] = 1"), Date) >= 3 Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
retval = objFSO.CopyFile(Source, Target, True)
Set objFSO = Nothing
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE WinAutoBackup SET WinAutoBackup.BackupDate = Date() WHERE [BckID] = 1;"
DoCmd.SetWarnings True
MsgBox "Backup successful. Next auto backup in 3 days."
End If
sysBackup_Exit:
Exit Function
sysBackup_Err:
MsgBox Err.Description, , "sysBackup()"
Resume sysBackup_Exit
End Function
Related
I'm sure there is a really easy way around this. Say I have a query called query_1 and upon running this query the user has to input the two values which are labelled as q_month, q_year.
I am running a bit of code that exports this query, but I want to take the user input values as strings which I can then use further down the line in my code. How would one do this?
(Apologies I am new to syntax in Access)
See below my attempt (I open the query first as it then will prompt user to input value). I know the lines v_Month and v_year are incorrect but hopefully it shows what I want to do clearer.
Thanks!
Function ExportExcel()
Dim myQueryName As String, sFolderPath As String, v_Month As String, v_Year As String
myQueryName = "query_1"
sFolderPath = "C:\Folder1"
DoCmd.OpenQuery myQueryName
v_Month = [query_1].[q_month]
v_Year = [query_1].[q_year]
myExportFileNameExcel = sFolderPath & "\" & v_Month & "\Test.xlsx"
DoCmd.OutputTo acOutputQuery, myQueryName, "ExcelWorkbook(*.xlsx)", myExportFileNameExcel, False, "", , acExportQualityPrint
End Function
You can use InputBox:
SomeStringVariable = InputBox("Please enter value:")
To set the parameters before running the query, use DoCmd.SetParameter:
DoCmd.SetParameter method (Access)
You haven't given the SQL for the query so I wrote a basic query showing how to use parameters:
PARAMETERS q_month Long, q_year Long;
SELECT *
FROM Table1
WHERE YEAR(DateField) = q_year AND MONTH(DateField) = q_month
You can then use this code to export the query data to Excel:
Sub Test()
Dim MonthNumber As Long, YearNumber As Long
'Get the details from the user.
MonthNumber = InputBox("Enter month number:")
YearNumber = InputBox("Enter full year:")
'Pass the details to the Export procedure.
ExportToExcel MonthNumber, YearNumber
End Sub
Public Function ExportToExcel(lMonth As Long, lYear As Long)
Dim qdf As DAO.QueryDef
Dim rst As DAO.Recordset
Dim fld As DAO.Field
Dim oXL As Object, oWB As Object, oWS As Object
'Open the query as a recordset.
Set qdf = CurrentDb.QueryDefs("Query1")
With qdf
.Parameters("q_Month") = lMonth
.Parameters("q_Year") = lYear
Set rst = .OpenRecordset
End With
Set oXL = CreateXL 'Create an instance of Excel.
Set oWB = oXL.WorkBooks.Add 'Create workbook.
Set oWS = oWB.Worksheets(1) 'Reference to first sheet.
'Copy the data over to row 2.
oWS.Range("A2").CopyFromRecordset rst
'Add the field headings to row 1
For Each fld In rst.Fields
oWS.cells(1, fld.OrdinalPosition + 1) = fld.Name
Next fld
'Using the passed values again.
MsgBox "Data exported for " & Format(DateSerial(lYear, lMonth, 1), "mmmm 'yy")
'Assumes the month folder already exists.
'Names folders as "01_January_18" to "12_December_18"
oWB.SaveAs "C:\Folder1\" & Format(DateSerial(lYear, lMonth, 1), "mm_mmmm_yy") & "\Test.xlsx", 51
rst.Close
qdf.Close
Set rst = Nothing
Set qdf = Nothing
End Function
Public Function CreateXL(Optional bVisible As Boolean = True) As Object
Dim oTmpXL As Object
'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Defer error trapping in case Excel is not running. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
Set oTmpXL = GetObject(, "Excel.Application")
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'If an error occurs then create an instance of Excel. '
'Reinstate error handling. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Err.Number <> 0 Then
Err.Clear
Set oTmpXL = CreateObject("Excel.Application")
End If
oTmpXL.Visible = bVisible
Set CreateXL = oTmpXL
End Function
I am getting a run-time error invalid procedure (error # 5) on this line:
afiles(countoflines).Delete True
I can't understand why. The save copy to the path works fine, and the assignation of the FSO to the folder files works , but I can't delete the 'x'th indexed item in the folder. Can someone assist with this?
Thanks
Option Explicit
Private Sub Workbook_Open()
Dim aFSO As New Scripting.FileSystemObject
Dim aFolder As Object
Dim aFiles As Object
Set aFolder = aFSO.GetFolder("R:\Groups\Finance\Ops Finance\Reporting\F18 Cost Analysis\Standard Costing\Std Cost Variances\Variance Master Back-Ups\")
If aFolder Is Nothing Then MsgBox "Directory not found!", vbExclamation: Exit Sub
Set aFiles = aFolder.Files
Application.StatusBar = "Saving back up copy"
ThisWorkbook.SaveCopyAs aFolder.Path & "\" & _
VBA.Replace(ThisWorkbook.Name, ".xlsm", "") & "_copy_" & _
VBA.Format$(Now, "m-d-yyyy hhmmss AM/PM") & ".xlsm"
Call CleanUpArchive(aFolder, aFolder.Path & Chr(92), aFiles.Count)
Set aFolder = Nothing
Set aFSO = Nothing
End Sub
'Cleans up archive file by deleting the 11th file (oldest copy)
Private Function CleanUpArchive(Folder As Object, Path As String, _
CountofFiles As Integer)
Dim aFiles As Scripting.Files
Set aFiles = Folder.Files
If CountofFiles > 10 Then
aFiles(CountofFiles).Delete True
End If
Set aFiles = Nothing
End Function
Untested, written on mobile. The below is not that different from your code, but might do what you need.
Option Explicit
Private Sub Workbook_Open()
Dim folderPath as string
folderPath = dir$("R:\Groups\Finance\Ops Finance\Reporting\F18 Cost Analysis\Standard Costing\Std Cost Variances\Variance Master Back-Ups\", vbdirectory)
If Len(folderPath) = 0 then
Msgbox("Could not locate folder")
Exit sub
Elseif strcomp(right(folderPath, 1),"\", vbbinarycompare) <> 0 then ' this might be unnecessary, depends if dir() on vbdirectory returns \ at end or not, cannot remember or test'
folderPath = folderPath & "\"
End if
Dim filenames() as string
Redim filenames(1 to 2, 1 to 1000) ' 1000 = magic number, change if needed.'
Dim fileIndex as long
Dim filename as string
Filename = dir$(folderPath & "*")
Do until Len(filename) = 0
Fileindex = fileindex +1
Filename(1, fileindex) = folderPath & filename
Filenames(2, fileindex) = filedatetime(Filename(1, fileindex))
Filename = dir$()
Loop
Redim preserve filenames(1 to 2, 1 to fileindex)
ThisWorkbook.SaveCopyAs folderPath & _
VBA.Replace(ThisWorkbook.Name, ".xlsm", "_copy_" & _
VBA.Format$(Now, "m-d-yyyy hhmmss AM/PM") & ".xlsm")
Dim Oldest as Date
Dim OldestIndex as long
Oldest = filenames(2,1) ' Initialise with first value'
' Might be better to store below in dictionary -- or any key-value/associative structure. But should work nonetheless.'
For fileindex = lbound(filenames,2) to ubound(filenames,2)
If filenames(2, fileindex) < oldest then
Oldest = filenames(2, fileindex)
OldestIndex = fileindex
End if
Next fileindex
Dim fileIsOpen as Boolean
On error resume next
Open filenames(1, OldestIndex) For Input Lock Read As #1
fileIsOpen = err.number <> 0
On error goto 0
Close #1
If fileIsOpen then
msgbox("Attempted to delete file at:" & filenames(1, OldestIndex) & " but file may be open elsewhere or by another user.")
Exit sub
Else
' In theory, the file could go from not-in-use to in-use between the check above and the delete below. Might be better just to try to kill without checking but with on error resume, and then checking if file still exists or is open.'
Kill filenames(1, OldestIndex)
End if
End sub
It started on Monday this week, when I finished with my code,the codes purpose was to pull data from a specific sheet in a specific folder from all spreadsheets in that folder.
But just last night he started crashing excel spreadsheet every time i pushed the run button.
Any idea why?
Option Explicit
Sub ImportSheet()
Dim i As Integer
Dim SourceFolder As String
Dim FileList As Variant
Dim GrabSheet As String
Dim FileType As String
Dim ActWorkBk As String
Dim ImpWorkBk As String
Dim NoImport As Boolean
Application.EnableEvents = False
SourceFolder = "C:\Users\Jarryd.Ward\Desktop\Test\"
FileType = "*.xlsx"
GrabSheet = "Summary"
FileList = ListFiles(SourceFolder & "/" & FileType)
Application.ScreenUpdating = False
ActWorkBk = ActiveWorkbook.Name
NoImport = False
For i = 1 To UBound(FileList)
Workbooks.Open (SourceFolder & "\" & FileList(i))
ImpWorkBk = ActiveWorkbook.Name
On Error Resume Next
ActiveWorkbook.Sheets(GrabSheet).Select
If Err > 0 Then
NoImport = True
GoTo nxt
End If
Err.Clear
On Error GoTo 0
ActiveWorkbook.Sheets(GrabSheet).Copy After:=Workbooks(ActWorkBk).Sheets(Workbooks(ActWorkBk).Sheets.Count)
ActiveSheet.Name = ImpWorkBk
On Error Resume Next
ActiveSheet.Name = FileList(i) & " - " & GrabSheet
Err.Clear
On Error GoTo 0
nxt:
Workbooks(ImpWorkBk).Activate
Application.DisplayAlerts = False
ActiveWorkbook.Saved = True
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
Workbooks(ActWorkBk).Activate
Next i
Application.ScreenUpdating = True
End Sub
Try opening and closing your files this way to see if it helps. It should minimize the calls to activate this or that. And closing out by variable instead of activesheet will insure that your code isn't trying to close the main workbook by accident.
Sub testOpen()
Dim manyWBs As Workbook
Dim myWB As Workbook
Set myWB = ThisWorkbook
For Each file In folder
Set manyWBs = Workbooks.Open("C:\temp\filename")
' do events.......
manyWBs.Worksheets("Sheet1").Range("A1:B13").Copy _
Destination:=myWB.Worksheets("Sheet1").Range("A1:b13")
manyWBs.Close
Set manyWBs = Nothing
Next file
Set myWB = Nothing
End Sub
I have been using this syntax which will export every table in a database to ONE excel workbook, but now my needs are to export every table to it's own workbook. How could this be tweaked to export each table to it's own workbook?
Sub ExportToExcel()
Dim td As DAO.TableDef, db As DAO.Database
Dim out_file As String
out_file = "C:\fromaccess.xlsx"
Set db = CurrentDb()
For Each td in db.TableDefs
If Left(td.Name, 4) = "MSys" Then
'Do Nothing
Else
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, td.Name, out_file, True, Replace(td.Name, "dbo_","")
End If
Next
End Sub
EDIT
I tried the suggestion by #HA560 but get an error of
Run-time error '91':
Object variable or With block variable not set
This is updated code:
Sub ExportToExcel()
Dim td As DAO.TableDef, db As DAO.Database
Dim out_file As String
Dim xl As Excel.Application
out_file = "C:\fromaccess.xlsx"
Set db = CurrentDb()
For Each td in db.TableDefs
xl.Workbooks.Add
If Left(td.Name, 4) = "MSys" Then
'Do Nothing
Else
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, td.Name, out_file, True, Replace(td.Name, "dbo_","")
End If
Next
End Sub
Bit of a long one which includes a three procedures. After running you should have a list of table names and TRUE/FALSE in the immediate window saying whether the export was successful.
ExportAll - The main procedure.
CreateXL - this creates an instance of Excel. It uses late binding, so no need to set references.
QueryExportToXL - this is the code to export the table. I haven't used TransferSpreadsheet as I like more control.
You need to pass a worksheet reference to the function.
You can pass either a query name or a recordset to the function.
You can pass an alternative sheet name.
The default cell to paste into is A1, but you can change this.
By default it adjusts the column widths to fit.
You can pass a collection of heading names to use instead of the field names.
There's not much error handling in there - such as passing a different number of heading names than there are fields, giving illegal sheet names.
It needs work :)
Public Sub ExportAll()
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim rst As DAO.Recordset
Dim oXL As Object
Dim oWrkBk As Object
Set db = CurrentDb
'Create instance of Excel.
Set oXL = CreateXL
For Each tdf In db.TableDefs
If Left(tdf.Name, 4) <> "MSys" Then
'Create workbook with single sheet.
Set oWrkBk = oXL.WorkBooks.Add(-4167) 'xlWBATWorksheet
'Open the table recordset.
Set rst = tdf.OpenRecordset
'In the immediate window display table name and TRUE/FALSE if exported successfully.
Debug.Print tdf.Name & " - " & QueryExportToXL(oWrkBk.worksheets(1), , rst, tdf.Name)
'Save and close the workbook.
oWrkBk.SaveAs "<path to folder>" & tdf.Name
oWrkBk.Close
End If
Next tdf
End Sub
'----------------------------------------------------------------------------------
' Procedure : CreateXL
' Author : Darren Bartrup-Cook
' Date : 02/10/2014
' Purpose : Creates an instance of Excel and passes the reference back.
'-----------------------------------------------------------------------------------
Public Function CreateXL(Optional bVisible As Boolean = True) As Object
Dim oTmpXL As Object
'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Defer error trapping in case Excel is not running. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
Set oTmpXL = GetObject(, "Excel.Application")
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'If an error occurs then create an instance of Excel. '
'Reinstate error handling. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Err.Number <> 0 Then
Err.Clear
On Error GoTo ERROR_HANDLER
Set oTmpXL = CreateObject("Excel.Application")
End If
oTmpXL.Visible = bVisible
Set CreateXL = oTmpXL
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure CreateXL."
Err.Clear
End Select
End Function
'----------------------------------------------------------------------------------
' Procedure : QueryExportToXL
' Author : Darren Bartrup-Cook
' Date : 26/08/2014
' Purpose : Exports a named query or recordset to Excel.
'-----------------------------------------------------------------------------------
Public Function QueryExportToXL(wrkSht As Object, Optional sQueryName As String, _
Optional rst As DAO.Recordset, _
Optional SheetName As String, _
Optional rStartCell As Object, _
Optional AutoFitCols As Boolean = True, _
Optional colHeadings As Collection) As Boolean
Dim db As DAO.Database
Dim prm As DAO.Parameter
Dim qdf As DAO.QueryDef
Dim fld As DAO.Field
Dim oXLCell As Object
Dim vHeading As Variant
On Error GoTo ERROR_HANDLER
If sQueryName <> "" And rst Is Nothing Then
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Open the query recordset. '
'Any parameters in the query need to be evaluated first. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set db = CurrentDb
Set qdf = db.QueryDefs(sQueryName)
For Each prm In qdf.Parameters
prm.Value = Eval(prm.Name)
Next prm
Set rst = qdf.OpenRecordset
End If
If rStartCell Is Nothing Then
Set rStartCell = wrkSht.cells(1, 1)
Else
If rStartCell.Parent.Name <> wrkSht.Name Then
Err.Raise 4000, , "Incorrect Start Cell parent."
End If
End If
If Not rst.BOF And Not rst.EOF Then
With wrkSht
Set oXLCell = rStartCell
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Paste the field names from the query into row 1 of the sheet. '
'Or the alternative field names provided in a collection. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If colHeadings Is Nothing Then
For Each fld In rst.Fields
oXLCell.Value = fld.Name
Set oXLCell = oXLCell.Offset(, 1)
Next fld
Else
For Each vHeading In colHeadings
oXLCell.Value = vHeading
Set oXLCell = oXLCell.Offset(, 1)
Next vHeading
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Paste the records from the query into row 2 of the sheet. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set oXLCell = rStartCell.Offset(1, 0)
oXLCell.copyfromrecordset rst
If AutoFitCols Then
.Columns.Autofit
End If
If SheetName <> "" Then
.Name = SheetName
End If
'''''''''''''''''''''''''''''''''''''''''''
'TO DO: Has recordset imported correctly? '
'''''''''''''''''''''''''''''''''''''''''''
QueryExportToXL = True
End With
Else
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'There are no records to export, so the export has failed. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
QueryExportToXL = False
End If
Set db = Nothing
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure QueryExportToXL."
Err.Clear
Resume
End Select
End Function
After for each use workbooks.add()method...out_file=activeworkbook.path
So I have this code in Mcirosoft Outlook. The code runs when new mail comes in, and depending on the sender's name and the attachments, it saves the text files and imports the data into 2 access databases and and runs certain queries pre built in the database. The code errors out when 2 emails which are from the right sender and has the right attachments comes in. The code processes the first email correctly however when the second email is getting processed, the code errors out at the bolded line below.
Option Explicit
Private Sub Application_NewMail()
Dim ns As NameSpace
Dim inbox As MAPIFolder
Dim Item As MailItem
Dim atmt As Attachment
Dim fso As FileSystemObject
Dim fs As TextStream
Dim dt, invfn, misfn, invdr, misdr, dbfn As String
Dim invt, mist As Boolean
Dim db As Object
Set ns = GetNamespace("MAPI")
Set inbox = ns.GetDefaultFolder(olFolderInbox)
Set fso = New FileSystemObject
If inbox.UnReadItemCount = 0 Then
Exit Sub
Else
For Each Item In inbox.Items.Restrict("[UnRead] = True")
If Item.SenderName = "Menon, Jayesh" Then
dt = Left(Right(Item.Subject, 12), 10)
For Each atmt In Item.Attachments
If atmt.FileName = "InvalidLoans.txt" Then
invfn = "ERLMF_InvalidLoans_" & dt & ".txt"
invdr = "C:\Documents and Settings\U299482\Desktop\Data Drop\" & _
invfn
atmt.SaveAsFile invdr
Set fs = fso.OpenTextFile(invdr)
If fs.Read(23) = "Invalid Loans Count = 0" Then
invt = False
Else
invt = True
End If
fs.Close
End If
If atmt.FileName = "MissingLoans.txt" Then
misfn = "ERLMF_MissingLoans_" & dt & ".txt"
misdr = "C:\Documents and Settings\U299482\Desktop\Data Drop\" & _
misfn
atmt.SaveAsFile misdr
Set fs = fso.OpenTextFile(misdr)
If fs.Read(23) = "Missing Loans Count = 0" Then
mist = False
Else
mist = True
End If
fs.Close
End If
Next
If invt = True Or mist = True Then
Set db = CreateObject("Access.Application")
dbfn = "C:\Documents and Settings\U299482\Desktop\Databases\BPDashboard.accdb"
With db
.OpenCurrentDatabase dbfn, True
.Visible = True
If invt = True Then
.DoCmd.TransferText acImportDelim, "Lns_Spec", "Invalid_Lns", invdr, True
End If
If mist = True Then
.DoCmd.TransferText acImportDelim, "Lns_Spec", "Missing_Lns", misdr, True
End If
.Quit
End With
Set db = Nothing
End If
If invt = True Then
Set db = CreateObject("Access.Application")
dbfn = "C:\Documents and Settings\U299482\Desktop\Databases\CORE IDP.accdb"
With db
.OpenCurrentDatabase dbfn, True
.Visible = True
**CurrentDb.Execute "A0_Empty_ERLMF_InvalidLoans_2013-04-02", dbFailOnError**
.DoCmd.TransferText acImportDelim, "Lns_Spec", "ERLMF_InvalidLoans_2013-04-02", invdr, True
CurrentDb.Execute "AppendERLMF", dbFailOnError
CurrentDb.Execute "FaxRF Crystal Append", dbFailOnError
.Quit
End With
Set db = Nothing
End If
Item.UnRead = False
End If
Next
End If
End Sub
I think you're getting over-lapping .Execute commands. You need to ensure that the first execution finishes before starting the next. To fix, I'd start by declaring a Public variable Executing then move the below code into its own method.
Sub Execute()
Executing = True
Set db = CreateObject("Access.Application")
dbfn = "C:\Documents and Settings\U299482\Desktop\Databases\CORE IDP.accdb"
With db
.OpenCurrentDatabase dbfn, True
.Visible = True
CurrentDb.Execute "A0_Empty_ERLMF_InvalidLoans_2013-04-02", dbFailOnError
.DoCmd.TransferText acImportDelim, "Lns_Spec", "ERLMF_InvalidLoans_2013-04-02", invdr, True
CurrentDb.Execute "AppendERLMF", dbFailOnError
CurrentDb.Execute "FaxRF Crystal Append", dbFailOnError
.Quit
End With
Set db = Nothing
Executing = False
End Sub
Then, when calling the function, surround it with a loop that tests to see if Executing is false.
Do
If Executing = False Then
Execute
Exit Do
End If
Loop