I'm having an issue where when I remove a reference from Access on close it does not stick. I have the function assigned to a hidden window that is always open and it works when I manually close the window, but when I close the database the change to remove the reference doesn't stick. We are having issues since part of our team is on Office 2013 so we have had to make a dynamic reference point in the VBA Code. The code to add the reference works fine, but removing it is the issue.
Here's the code for adding it
Public Function RunThis()
Dim ref As Reference
'For Each ref In Access.References
'MsgBox ref.Name
'Next
If Dir("C:\Program Files (x86)\Microsoft Office\Office15\EXCEL.exe") <> "" Then
Access.References.AddFromFile ("C:\Program Files (x86)\Microsoft Office\Office15\EXCEL.exe")
End If
If Dir("C:\Program Files (x86)\Microsoft Office\Office16\EXCEL.exe") <> "" Then
Access.References.AddFromFile ("C:\Program Files (x86)\Microsoft Office\Office16\EXCEL.exe")
End If
End Function
Here's the code that is run on exit
Private Sub Form_Close()
Dim ref As Reference
For Each ref In Access.References
If ref.Name = "Excel" Then
Access.Application.References.Remove ref
'MsgBox "Found It"
End If
MsgBox ref.Name
Next
DoCmd.Save
End Sub
Related
When I run this, I get run time error 3027: "Cannot update. Database or object is read-only."
Private Sub Export_Run()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogSaveAs)
If fd.Show = True Then
If Format(fd.SelectedItems(1)) <> vbNullString Then
DoCmd.TransferText acExportDelim, , "Export_tbl", fd.SelectedItems(1), False
End If
End If
End Sub
The table I'm trying to export (Export_tbl) exists and is editable (not read only), and I can manually export it without issue. I'm guessing this may be an issue with the machine I'm on, with permissions or something? Or am I using the filedialog reference incorrectly? Thanks for any help.
The problem was that I failed to properly assign a full file name for the table being exported---you need to include the file path, name, AND extension (at least in this case, since I'm trying to export as text/CSV). The following worked:
Private Sub Export_Run()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogSaveAs)
If fd.Show = True Then
If Format(fd.SelectedItems(1)) <> vbNullString Then
thename = fd.SelectedItems(1) & ".csv"
DoCmd.TransferText acExportDelim, , "Export_tbl", thename, False
End If
End If
End Sub
I used the code provided by Siddharth Rout in the following threat.
Detect whether Excel workbook is already open
My goal was to check if a certain named workbook was open and depending on the result perform certain actions.
This was the result.
Function IsWorkBookOpen(FileName As String)
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNo
End Select
End Function
The following piece refers back to the function and depending on the result performs certain actions.
Dim xls As Object
Dim Answer As String
Dim Mynote As String
If IsWorkBookOpen(Environ("USERPROFILE") & "\Desktop\Report.xlsm") =
True Then
Mynote = "The Report is still open. Do you want to save the Report ?"
Answer = MsgBox(Mynote, vbQuestion + vbYesNo, "Warning Report open")
If Answer = vbYes Then
MsgBox "Please Save your Report under a new name and close it. then press update again"
Exit Sub
Else
Set xls = GetObject(Environ("USERPROFILE") & "\Desktop\Report.xlsm")
xls.Close True
End If
Else
End If
This used to work perfectly in the past but since today it suddenly gives me error 53.
While trying to resolve the issue I discovered the error only occurs when the named workbook is not on the desktop. Strangely enough it did not have this issue in the past. I specifically tested that because the file will not always be on the desktop.
I tried several backups tracking back 2 months and even those show the same error now.
While searching the internet for this issue i found this thread,
Check if excel workbook is open?
where they suggest to change the following pieces,
(ErrNo = Err) in to (Errno = Err.Number)
(ff = FreeFile_()) in to (ff = FreeFile)
I did both together and independitly. eventhough i dont really see the relation between the error and Freefile.
This did not change the error at all.
While I am currious to why this error suddenly occurs I really do need a solution or alternative.
what i need it tot do again is,
- Check if named workbook is open.
- when it is open a Msgbox with yes and no option should appear.
- On "No" it should close the named workbook and continue with whatever is below of what i posted.
- On yes it should pop a message box and stop.
Any help that can be provided will be highly appreciated.
You need to check if the file exists before checking if it is open;
Function FileExists(ByVal strFile As String, Optional bFindFolders As Boolean) As Boolean
'Purpose: Return True if the file exists, even if it is hidden.
'Arguments: strFile: File name to look for. Current directory searched if no path included.
' bFindFolders. If strFile is a folder, FileExists() returns False unless this argument is True.
'Note: Does not look inside subdirectories for the file.
'Author: Allen Browne. http://allenbrowne.com June, 2006.
Dim lngAttributes As Long
'Include read-only files, hidden files, system files.
lngAttributes = (vbReadOnly Or vbHidden Or vbSystem)
If bFindFolders Then
lngAttributes = (lngAttributes Or vbDirectory) 'Include folders as well.
Else
'Strip any trailing slash, so Dir does not look inside the folder.
Do While Right$(strFile, 1) = "\"
strFile = Left$(strFile, Len(strFile) - 1)
Loop
End If
'If Dir() returns something, the file exists.
On Error Resume Next
FileExists = (Len(Dir(strFile, lngAttributes)) > 0)
End Function
I'm trying to implement a certain feature in the Microsoft Access Database using VBA, so when a certain button is pressed, it will check first the availability of the folder in a server. If the folder doesn't exist, the corresponding folder will be created. However, the folders have permissions attached to them, which means only certain users can access it, and hence only certain users should create / access the folder. I have tried the following:
on error resume next
If Dir("Server/Data/Celes", vbDirectory) = "Celes" Then
Else
MkDir ("Server/Data/Celes")
End If
But I'm not sure if it's the best way to handle this problem. I use the "On Error Resume Next", so that if the error occurs due to the lack of permission to the folder (that already exists), it will ignore it. What are some better ways to handle this? Thank you.
I also have checked the following links:
https://social.msdn.microsoft.com/Forums/office/en-US/a79054cb-52cf-48fd-955b-aa38fd18dc1f/vba-verify-if-user-has-permission-to-directory-before-saveas-attempt?forum=exceldev
Check Folder Permissions Before Save VBA
but both of them concerns with saving the file, not creating folder.
After several days without success, finally I found the solution:
Private function canAccess(path as string) as boolean
Dim oShell As Object
Set oShell = CreateObject("WScript.Shell")
Dim result As Integer
Dim command As String
command = "icacls " & """" & pfad & """"
result = oShell.Run(command, 0, True)
'Check privilege; file can be accessed if error code is 0.
'Else, errors are encountered, and error code > 0.
If result <> 5 and result <> 6 Then
KannAufDateiZugreifen = True
Else
KannAufDateiZugreifen = False
End If
end function
private sub button_click()
if canAccess ("Server/Data/Celes") then
If Dir("Server/Data/Celes", vbDirectory) = "Celes" Then
Else
MkDir ("Server/Data/Celes")
end if
End If
end sub
The function "canAccess" will simulate the running of the Windows shell, and execute "icacls" to see if the file can be accessed or not. If the function returns true, it means the "icacls" command is successful, which means the folder can be accessed. Otherwise, the file / folder can not be accessed.
I'm pretty sure this can be improved, but for now, it works.
I use the below function that recursively creates the full path (if required) and returns a value indicating success or failure. It works also with UNCs.
Private Function CreateFolder(ByVal sPath As String) As Boolean
'by Patrick Honorez - www.idevlop.com
'checks for existence of a folder and create it at once, if required
'returns False if folder does not exist and could NOT be created, True otherwise
'sample usage: If CreateFolder("C:\toto\test\test") Then debug.print "OK"
'updated 20130422 to handle UNC paths correctly ("\\MyServer\MyShare\MyFolder")
Dim fs As Object
Dim FolderArray
Dim Folder As String, i As Integer, sShare As String
If Right(sPath, 1) = "\" Then sPath = Left(sPath, Len(sPath) - 1)
Set fs = CreateObject("Scripting.FileSystemObject")
'UNC path ? change 3 "\" into 3 "#"
If sPath Like "\\*\*" Then
sPath = Replace(sPath, "\", "#", 1, 3)
End If
'now split
FolderArray = Split(sPath, "\")
'then set back the # into \ in item 0 of array
FolderArray(0) = Replace(FolderArray(0), "#", "\", 1, 3)
On Error GoTo hell
'start from root to end, creating what needs to be
For i = 0 To UBound(FolderArray) Step 1
Folder = Folder & FolderArray(i) & "\"
If Not fs.FolderExists(Folder) Then
fs.CreateFolder (Folder)
End If
Next
CreateFolder = True
hell:
End Function
'Must set a Reference to the Microsoft Scripting Runtime
Dim fso As FileSystemObject
Dim fil As File
Set fso = New Scripting.FileSystemObject
If fso.FileExists("\\serverName\folderName\fileName.txt") Then
'code execution here
Else
MsgBox "File and/or Path cannot be found", vbCritical, "File Not Found"
End If
This question is very similar to the previously posted question: Save each sheet in a workbook to separate CSV files
However, my requirements are slightly different in that I need to have the ability to ignore specifically named worksheets (see #2 below).
I have been successful in utilizing the solution posted in this answer: https://stackoverflow.com/a/845345/1289884 which was posted in response to the question above meets almost all of my requirements with the exception of #2 below and #3 below:
I have an excel 2010 workbook that consists of multiple worksheets and I am looking for a macro that will:
Save each worksheet to a separate comma delimited CSV file.
Ignore specific named worksheet(s) (i.e. a sheet named TOC and sheet name Lookup)
Save files to a specified folder (example: c:\csv)
Ideal Solution would additionally:
Create a zip file consisting of all of the CSV worksheets within a specified folder
Any help would be greatly appreciated.
Nick,
Given you expanded on your question with the differences, and the zip part is a significant addon I have outlined a solution below that:
Creates the CSV file, skipping specific sheets using this line Case "TOC", "Lookup"
Adds them to a Zip file. This section draws heavily on Ron de Bruin's code here
The code will create the paths under StrMain and StrZipped if they do not already exists
As the ActiveWorkbook gets sub-divided into CSV files the code tests that the ActiveWorkbook is saved prior to proceeding
On (2) I ran across an issue I have seen before in my Produce an Excel list of the attributes of all MP3 files that sit in or below the "My Music" folde where the Shell.Application errored when string variables were passed to it. So I gritted my teeth and added a hardcoding of the earlier paths for Zip_All_Files_in_Folder. I commented out my earlier variable passing to show where I tried this
VBA to save CSVS
Public Sub SaveWorksheetsAsCsv()
Dim ws As Worksheet
Dim strMain As String
Dim strZipped As String
Dim strZipFile As String
Dim lngCalc As Long
strMain = "C:\csv\"
strZipped = "C:\zipcsv\"
strZipFile = "MyZip.zip"
If Not ActiveWorkbook.Saved Then
MsgBox "Pls save " & vbNewLine & ActiveWorkbook.Name & vbNewLine & "before running this code"
Exit Sub
End If
With Application
.DisplayAlerts = False
.ScreenUpdating = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
End With
'make output diretcories if they don't exist
If Dir(strMain, vbDirectory) = vbNullString Then MkDir strMain
If Dir(strZipped, vbDirectory) = vbNullString Then MkDir strZipped
For Each ws In ActiveWorkbook.Worksheets
Select Case ws.Name
Case "TOC", "Lookup"
'do nothing for these sheets
Case Else
ws.SaveAs strMain & ws.Name, xlCSV
End Select
Next
'section to run the zipping
Call NewZip(strZipped & strZipFile)
Application.Wait (Now + TimeValue("0:00:01"))
Call Zip_All_Files_in_Folder '(strZipped & strZipFile, strMain)
'end of zipping section
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = lngCalc
End With
End Sub
'Create the ZIP file if it doesn't exist
Sub NewZip(sPath As String)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
'Add the files to the Zip file
Sub Zip_All_Files_in_Folder() '(sPath As String, ByVal strMain)
Dim oApp As Object
Set oApp = CreateObject("Shell.Application")
'Shell doesn't handle the variable strings in my testing. So hardcode the same paths :(
sPath = "C:\zipcsv\MyZip.zip"
strMain = "c:\csv\"
'Copy the files to the compressed folder
oApp.Namespace(sPath).CopyHere oApp.Namespace(strMain).items
MsgBox "You find the zipfile here: " & sPath
End Sub
we have an Access-Application which does not work on some clients, mainly because references are broken. That happens for example when you start the access application with access runtime 2007 but have office in version 2003 or 2000 installed. Functions like Left/Right/Trim etc. just stop working then.
I think the only way to fix this problem is to programmtically check which office version is installed and add the references programmatically as in these heterogenous environments we cannot control what the user has installed. Specifically I need to reference the Microsoft Office Object libraries for Excel and Word.
But I neither have the guids of all office versions nor have a clue how to check them automatically.
So yeah, this answer is a bit late, but just in case someone stumbles across this like I did looking for an answer, I figured out the following bit of code to add an excel reference and it seems to work fine, also in MDE/ACCDE!
If Dir("C:\Program Files (x86)\Microsoft Office\Office12\EXCEL.exe") <> "" And Not refExists("excel") Then
Access.References.AddFromFile ("C:\Program Files (x86)\Microsoft Office\Office12\EXCEL.exe")
End If
If Dir("C:\Program Files (x86)\Microsoft Office\Office14\EXCEL.exe") <> "" And Not refExists("excel") Then
Access.References.AddFromFile ("C:\Program Files (x86)\Microsoft Office\Office14\EXCEL.exe")
End If
If Dir("C:\Program Files (x86)\Microsoft Office\Office12\EXCEL.exe") = "" And Dir("C:\Program Files (x86)\Microsoft Office\Office14\EXCEL.exe") = "" Then
MsgBox ("ERROR: Excel not found")
End If
And the refExists references the following function:
Private Function refExists(naam As String)
Dim ref As Reference
refExists = False
For Each ref In References
If ref.Name = naam Then
refExists = True
End If
Next
End Function
If you ship an MDE/ACCDE you can't update your references.
But what specific references are causing you your problems? Chances are you are referencing Word, Excel or Outlook. If so use late binding so your solution doesn't matter what version is installed on the client system.
Late binding means you can safely remove the reference and only have an error when the app executes lines of code in question. Rather than erroring out while starting up the app and not allowing the users in the app at all. Or when hitting a mid, left or trim function call.
This also is very useful when you don't know what version of the external application will reside on the target system. Or if your organization is in the middle of moving from one version to another.
For more information including additional text and some detailed links see the "Late Binding in Microsoft Access" page.
Here is an example - it check for certain references - deleting them and importing the Access 2000 variant. Just to make sure all clients use the same (lowest) version of the dependencies
Sub CheckReference()
' This refers to your VBA project.
Dim chkRef As Reference ' A reference.
Dim foundWord, foundExcel As Boolean
foundWord = False
foundExcel = False
' Check through the selected references in the References dialog box.
For Each chkRef In References
' If the reference is broken, send the name to the Immediate Window.
If chkRef.IsBroken Then
Debug.Print chkRef.Name
End If
If InStr(UCase(chkRef.FullPath), UCase("MSWORD9.olb")) <> 0 Then
foundWord = True
End If
If InStr(UCase(chkRef.FullPath), UCase("EXCEL9.OLB")) <> 0 Then
foundExcel = True
End If
If InStr(UCase(chkRef.FullPath), UCase("MSWORD.olb")) <> 0 Then
References.Remove chkRef
ElseIf InStr(UCase(chkRef.FullPath), UCase("EXCEL.EXE")) <> 0 Then
References.Remove chkRef
End If
Next
If (foundWord = False) Then
References.AddFromFile ("\\pathto\database\MSWORD9.OLB")
End If
If (foundExcel = False) Then
References.AddFromFile ("\\pathto\database\EXCEL9.OLB")
End If
End Sub
Here is a code sample, which checks for broken references. I know this is not the whole solution for you, but it will give you some clues how to do it.
Public Function CheckRefs()
On Error GoTo Handler
Dim rs As Recordset
Dim ref As Reference
Dim msg As String
For Each ref In Application.References
' Check IsBroken property.
If ref.IsBroken = True Then
msg = msg & "Name: " & ref.Name & vbTab
msg = msg & "FullPath: " & ref.FullPath & vbTab
msg = msg & "Version: " & ref.Major & "." & ref.Minor & vbCrLf
End If
Next ref
If Len(msg) > 0 Then MsgBox msg
Exit Function
Handler:
' error codes 3075 and 3085 need special handling
If Err.Number = 3075 Or Err.Number = 3085 Then
Err.Clear
FixUpRefs
Else
rs.Close
Set rs = Nothing
End If
End Function
Private Sub FixUpRefs()
Dim r As Reference, r1 As Reference
Dim s As String
' search the first ref which isn't Access or VBA
For Each r In Application.References
If r.Name <> "Access" And r.Name <> "VBA" Then
Set r1 = r
Exit For
End If
Next
s = r1.FullPath
' remove the reference and add it again from file
References.Remove r1
References.AddFromFile s
' hidden syscmd to compile the db
Call SysCmd(504, 16483)
End Sub