Still new to access so not sure if this is even possible or if I should just add a separate button, basically I have written code to import excel documents and I need the form to refresh/requery once the import has been completed.
I've tried both me.refresh and me.requery however the form doesn't update.
Private Sub ImportBlacklist_Click()
Dim SelectedFile As String
Dim FilePicker As FileDialog
Dim SQLdelete As String
Set FilePicker = Application.FileDialog(msoFileDialogFilePicker)
FilePicker.AllowMultiSelect = False
FilePicker.Filters.Add "Excel", "*.xls*", 1
FilePicker.InitialFileName = "C:\Users\"
FilePicker.Title = "Select Suppression List Location..."
FilePicker.Show
If FilePicker.SelectedItems.Count <> 0 Then
SelectedFile = FilePicker.SelectedItems(1)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "Blacklist", SelectedFile, True
MsgBox ("Import Success")
End If
Exit Sub
Me.Requery
ErrorHandler:
MsgBox "There was an Error: " & Err & ": " & Error(Err)
End Sub
The import all works perfectly as intended, I just need it to update the form once the MsgBox has closed
You have
Exit Sub
Me.Requery
Me.Requery would do the job, but it isn't executed because of Exit Sub before.
Switch the two lines.
Related
Using Microsoft Access: there is a form. On the form is a textbox containing a name. There is a button on the form which, when clicked, runs vba code that looks at the name on the form then opens the like named folder. The database and folder reside in the same directory. Two users have reported that, instead of the folder opening, Internet Explorer opens for them (to their default webpage).
Code for the button:
Private Sub cmdNewOpenFolder_Click()
'Uses the OpenFolderMod module to open the folder for the active record in file explorer, and create
'one if it doesn't yet exist
On Error GoTo Err_Handler
If Me.chkComplete = True Then
MsgBox "This folder has been moved to the archive"
Exit Sub
Else:
Call OpenFolder(Me.FullName)
End If
Exit_Handler:
Exit Sub
Err_Handler:
If err.Number = 94 Then
MsgBox "Please add the name of the fugitive in the 'Name' text box in order" & vbCrLf & _
"for a folder to be created."
Else
MsgBox "Error " & err.Number & ": " & err.Description
End If
Resume Exit_Handler
End Sub
The Open Folder code:
Public Sub OpenFolder(fldName As String)
Dim strStartFilePath As String
Dim strEndFilePath As String
Dim Continue As String
On Error GoTo err
strStartFilePath = strBEPath & "\" & fldName
strEndFilePath = Dir(strStartFilePath & fldName & "*", vbDirectory)
Application.FollowHyperlink strStartFilePath & strEndFilePath
err:
If err.Number = 490 Then
Continue = MsgBox("There is no folder yet, do you want to create one?", _
vbYesNo, "Create Folder")
If Continue = vbYes Then
Call MakeFolder(strBEPath & "\" & fldName)
Application.FollowHyperlink strStartFilePath & strEndFilePath
Else: Exit Sub
End If
End If
End Sub
strBEPath is a constant that is the backend database location on a shared server. It looks like "\\{name of server}\{otherfoldername}\{otherfoldername with a space in the name}\etc." (there are five subfolders in all.)
Interestingly, there is a similar button which opens the "Project Folder" the folder with the database and subfolder and it works just fine:
Public Sub OpenProjFolder()
Application.FollowHyperlink strBEPath
'Debug.Print strBEPath
End Sub
I looked over the machines where this is happening and nothing looks out of the ordinary. Both users have all the right reference libraries and so on.
Any ideas as to why Internet Explorer is opening?
i've been struggling around trying to get my VBA to work & i'm at a loss since i'm extremely fresh using VBA or coding in-general.
What i've got is basically a Navigation Main Form that uses tabs to open up different forms for ease of access. On one of these subforms there is a button that is supposed to work as a "SaveAsPDF" option. it's basically supposed to work by opening up a folder you want to save it in, & exporting the Report version as a pdf to the location. The weird thing is that it works perfectly when you have the actual form open & not the form open in the navigation menu, so i'm at a loss now.
If anyone is able to help, it's much appreciated & you'll be saving alot of hair from the floor. What i've got is below
Private Sub SaveAsPDF_Click()
Dim fd As FileDialog
On Error goto ErrorHandler
Set fd = Application.FileDialog(msoFileDialogSaveAs)
With fd
.InitialFileName = MAFNO & ".pdf"
End With
If fd.Show Then
DoCmd.OutputTo acOutputReport, "RptMAFPrint", acFormatPDF, _
fd.SelectedItems(1), True
End If
Exit sub
ErrorHandler:
Msgbox "An Error occurred, please try again", vbinformation, "Could not save document"
Exit sub
End Sub
As far as it running on it's own when you open the actual form up, it works perfectly & hasn't had a single error, but when opening it up from the Navigation Menu Tab it immediately has an error & tries to save the entire workbook.
Error below
https://imgur.com/a/rSynDic
Longpast on this post, but Kostas had the answer & I was easily able to edit the vba to make it work. Thank you thank you kostas, if I could actually put yours as the answer, I would.
VBA is below if anyone would ever need it. I'll probably go back at some point & see if I could re-write it better, but it gets the job done for the most part.
This does work perfectly for a MS Access Navigation form though & it does not close the current active tab at the end of the VBA.
Private Sub ButtonSaveAsPDF_Click()
Dim fd As FileDialog
On Error GoTo ErrorHandler
DoCmd.Save
DoCmd.RefreshRecord
'==== Initial Check ====
If IsNull(Me.TxtMAFNumberTop) Then
GoTo Leave
ElseIf Not IsNull(Me.TxtMAFNumberTop) Then
GoTo Start
End If
'==== SaveAs PDF Start ====
Start:
Set fd = Application.FileDialog(msoFileDialogSaveAs)
With fd
.InitialFileName = TxtMAFNumberTop & ".pdf"
End With
If fd.Show Then
DoCmd.OpenForm "FrmMAF", acNormal, , "[ID] = " & ID, , acHidden
DoCmd.OutputTo acOutputReport, "RptMAFPrint", acFormatPDF, _
fd.SelectedItems(1), True
DoCmd.Close , "FrmMAF"
End If
Exit Sub
Leave:
Exit Sub
ErrorHandler:
MsgBox "An error occurred trying to print your MAF. Please try the following
below & try again" & vbCrLf & _
vbCrLf & _
"1) Verify current MAF information & fields are correct" & vbCrLf & _
"2) Cycle Records & try again " & vbCrLf & _
vbCrLf & _
"If this problem occurs again please contact your local Administrator", _
vbCritical + vbRetryCancel, _
"[Critical] ERROR : SaveAsPDF "
If vbRetry Then
GoTo Start
ElseIf vbCancel Then
Exit Sub
End If
End Sub
I have googled everywhere but I am unable to find out to do it without rewriting all the code, is there anyway to have this code check whether the file name matches table names and if it does then clear that table and re import or if not then create a new table?
Option Compare Database
Option Explicit
Private Sub btnBrowse_Click()
Dim diag As Office.FileDialog
Dim item As Variant
Set diag = Application.FileDialog(msoFileDialogFilePicker)
diag.AllowMultiSelect = False
diag.Title = "Please select an Excel Spreadsheet"
diag.Filters.Clear
diag.Filters.Add "Excel Spreadsheets", "*.xls, *.xlsx, *.xlsm"
If diag.Show Then
For Each item In diag.SelectedItems
Me.txtFileName = item
Next
End If
End Sub
Private Sub btnImportSpreadsheet_Click()
Dim FSO As New FileSystemObject
If FSO.FileExists(Nz(Me.txtFileName, "")) Then
ImportExcelSpreadsheet Me.txtFileName, FSO.GetFileName(Me.txtFileName)
ElseIf Nz(Me.txtFileName, "") = "" Then
MsgBox "Please select a file!", vbExclamation
Else
MsgBox "File not found!", vbExclamation
End If
End Sub
Public Sub ImportExcelSpreadsheet(Filename As String, TableName As String)
On Error Resume Next
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, TableName, Filename, True
If Err.Number = 3125 Then
If vbOK = MsgBox(Err.Description & vbNewLine & vbNewLine & "Skip column header and continue?", vbExclamation + vbOKCancel, "Error with Excel Column header") Then
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, TableName, Filename, False
MsgBox "Done", vbInformation
End If
Exit Sub
ElseIf Err.Number <> 0 Then
MsgBox Err.Number & ":" & Err.Description, vbCritical
Exit Sub
End If
MsgBox "Upload Complete", vbInformation
End Sub
Thank for any help
You'll have to rewrite some. Without looping through Tables collection and testing against each name, every method seems to involve handling an error. Here is one:
Function TableExists(strTableName As String) As Boolean
On Error Resume Next
TableExists = IsObject(CurrentDb.TableDefs(strTableName))
End Function
Call the function:
If TableExists("YourTableName") = True Then
More examples in How to check if a table exists in MS Access for vb macros
I have an Access 2013 database with all tables linked to SQL Server 2016 tables. I have an Excel 2013 (.xlsx) file, that I need to import into a a table in Ms Access that is linked to SQL Server via vba Code (all fields in xlsx and table are the same)
All my VBA code resides in the Access database, I have a form with a button with event in it, I try to use de "transferspreadsheet", an "Insert to" Clause for sql but neither of them has worked for me
Here is my code,
xtRuta2 name of the field in the form that have the path
Dim strArchivo2 String ' path of the file xlsx c:\reports\mireporte.xlsx
dim miAlerta2 as string
Dim ssql As String
strArchivo2 = txtRuta2
miAlerta2 = MsgBox("¿Do you want to import new information for " & strArchivo2 & "?" & vbCrLf & vbCrLf & "This operation will be update all the information", vbExclamation + vbOKCancel, "¡INFORMATION IMPORT ALERT!")
If miAlerta2 = vbOK Then
varAlert2 = MsgBox("Please confirm you want to import new information?", vbExclamation + vbOKCancel, "¡CONFIRMATION IMPORT ALERT!")
If varAlert2 = vbOK Then
'DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tbl_ZSales_Export Worksheet", strArchivo2, True, "Export Worksheet$"
ssql = "INSERT INTO [tbl_Export Worksheet] select * FROM OPENROWSET('Microsoft.ACE.OLEDB.12.0', 'Excel 12.0;Database=" & strArchivo2 & ";HDR=YES', 'SELECT * FROM [Export Worksheet$)'"
'CurrentDb.Execute ssql
MsgBox "Import Finished", vbExclamation + vbOKOnly
endif
end if
Can you please help me to write the correct code for this to work
Thanks regards!
This piece of code (late bdingin interaction with excel) is used to convert excel sheet to text file and then import to a table of your choosing. I prefer to use this method as access has an annoying habit of trying ot interpret your data for you when using transferspreadsheet. With creating an import spec (which you need to do to use this method), you can easily predefine the data types.
Option Compare Database
Option Explicit
Private Sub stuff()
On Error GoTo GetAccrualFile_Err
Dim fileLoc As String
Dim path As String, Sep As String, NewTextFile As String, WholeLine As String
Dim oXL As Object, sheet As Object
Dim i As Long, j As Long, counteri As Long, counterj As Long
Dim bringOver As Variant
DoCmd.SetWarnings False
DoCmd.Hourglass True
counteri = 0
counterj = 0
Sep ="your prefered delimiter"
DoCmd.RunSQL "DELETE * FROM TBL"
fileLoc = "UNC PATH AND FILE NAME" & ".xlsx"
path = Left(fileLoc, InStrRev(fileLoc, "\") - 1) & "\"
NewTextFile = "UNC PATH AND FILE NAME" & ".txt"
Set oXL = CreateObject("Excel.Application")
With oXL
.WorkBooks.Open FileName:=path & Dir$(fileLoc)
Open NewTextFile For Output As #2
bringOver = .Worksheets("your sheet name").UsedRange 'you might need to adjust this line to get the sheet your after
For i = LBound(bringOver, 1) To UBound(bringOver, 1)
For j = LBound(bringOver, 2) To UBound(bringOver, 2)
WholeLine = WholeLine & bringOver(i, j) & Sep
counterj = counterj + 1
Next j
'used if you want to skip column headers
If counteri <> 0 Then
Print #2, WholeLine
End If
WholeLine = ""
counteri = counteri + 1
counterj = 0
Next i
counteri = 0
Erase bringOver
End With
Close #2
DoCmd.TransferText acImportDelim, "importspecname", "tbltoimportto", NewTextFile, False
'***************************************************************************************
'you will need to learn how to set up import specs, as well as understand the arguments for DoCmd.TransferText
'***************************************************************************************
CleanUp:
DoCmd.SetWarnings True
DoCmd.Hourglass False
On Error Resume Next
DoEvents
oXL.Quit
oXL.Application.Quit
If Dir(NewTextFile) <> "" Then Kill NewTextFile
Erase bringOver
DoCmd.SetWarnings True
DoCmd.Hourglass False
Exit Sub
GetAccrualFile_Err:
DoCmd.SetWarnings True
DoCmd.Hourglass False
msgbox "An error has occured. " & " " & ERR.Number & " " & ERR.Description & " "
GoTo CleanUp
Resume
End Sub
Try EPPlus, a free library which allows you to manage Excel files from .Net platform.
Here you have a tutorial: https://riptutorial.com/epplus
The following code checks if file is open, if not, it opens it and copies something into it. It works fine on my computer. Will it work, when the file is shared and another user opens the file? Will my code detect it?
Sub copy_to_boss()
On Error Resume Next
team = "boss.xlsm"
Set fileBoss = Workbooks(team)
fileIsOpen = Not fileBoss Is Nothing
If fileIsOpen = True Then
MsgBox "The following file is open " & team & " - close it."
Else
MsgBox "I will open the following file " & team
Workbooks.Open Filename:=team
ActiveWorkbook.Worksheets("List1").Cells(1, 1).Value = "10"
End If
End Sub
Try this:
Sub test_LockFile()
Dim sFile As String
Dim sLockFile As String
Dim objFSO As Object
'Trick: Each Excel file in use has a temporary file companion with prefix "~$"
' (e.g. "test.xlsm" ... "$~test.xlsm")
'Define sLockFile
sFile = ThisWorkbook.Name
sLockFile = ThisWorkbook.Path & "\~$" & sFile
'FileSystemObject, late Binding ohne Nutzung von IntelliSense und autom. Konstanten
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Show message if file is locked
If objFSO.FileExists(sLockFile) Then
MsgBox "The file " & sLockFile & " is locked by some user.", vbInformation, sFile & " is locked"
Else
MsgBox "The file is available", vbInformation, sFile
End If
End Sub
You can use something like this to check if the file is in use:
Public Function IsFileLocked(PathName As String) As Boolean
On Error GoTo ErrHandler
Dim i As Integer
If Len(Dir$(PathName)) Then
i = FreeFile()
Open PathName For Random Access Read Write Lock Read Write As #i
Lock i 'Redundant but let's be 100% sure
Unlock i
Close i
Else
Err.Raise 53
End If
ExitProc:
On Error GoTo 0
Exit Function
ErrHandler:
Select Case Err.Number
Case 70 'Unable to acquire exclusive lock
IsFileOpen = True
Case Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
End Select
Resume ExitProc
Resume
End Function