VBA Script to check if text file is open or not - vba

I am checking if a file is open or not that is a .txt file
Private Sub CommandButton1_Click()
Dim strFileName As String
' Full path and name of file.
strFileName = "D:\te.txt"
' Call function to test file lock.
If Not FileLocked(strFileName) Then
' If the function returns False, open the document.
MsgBox "not open"
Else
MsgBox "open"
End If
End Sub
Function FileLocked(strFileName As String) As Boolean
On Error Resume Next
' If the file is already opened by another process,
' and the specified type of access is not allowed,
' the Open operation fails and an error occurs.
Open strFileName For Binary Access Read Write Lock Read Write As #1
Close #1
' If an error occurs, the document is currently open.
If Err.Number <> 0 Then
' Display the error number and description.
MsgBox "Error #" & Str(Err.Number) & " - " & Err.Description
FileLocked = True
Err.Clear
End If
End Function

It turns out .txt when opened using notepad doesn't lock the file, so it can not be known if a .txt file is open or not. And hence, if that .txt file is opened in Wordpad or Sakura, etc., your code should work or at least other code from the net should work.

I found that if a text file is opened using FileSystemObject, then the file is not locked and can still be edited by other users. As a potential workaround, you could make a file with a single bit to indicate when the other file is in use, and include checking that bit in your code. Here's my code as a rough example:
'FSO parameters
Const ForAppending = 8
Const ForReading = 1
Const ForWriting = 2
Sub WriteToFile()
Set fso = CreateObject("Scripting.FileSystemObject")
'Check the current lock bit (1 is locked, 0 is unlocked)
Set FileLock = fso.OpenTextFile("C:\FileLock.txt", ForReading)
Dim LockBit As Integer
LockBit = FileLock.ReadAll
FileLock.Close
'If the bit is 1 (file in use) then wait 1 second and try again (up to 10 times)
For try = 1 To 10
If LockBit = 1 Then
Application.Wait (Now + TimeValue("0:00:1"))
Set FileLock = fso.OpenTextFile("C:\FileLock.txt", ForReading)
LockBit = FileLock.ReadAll
FileLock.Close
Else: GoTo Line1 'when the bit is 0 (file available)
End If
If try = 10 Then
MsgBox "File not available"
Exit Sub
End If
Next try
Line1:
Call LockTheFile(fso, True) 'Change the lock bit to "1" to show the file's in use
Set WriteFile = fso.OpenTextFile("C:\WriteFile.txt", ForWriting)
'Do what you will with the file
MsgBox "Write Successful"
WriteFile.Close
Call LockTheFile(fso, False) 'Change the lock bit to "0" to show the file's available
End Sub
I made this sub separate to make the main code more streamlined
Sub LockTheFile(fso, SetLock As Boolean)
'Write "1" to a lock file to indicate the text file is in use, or "0" to indicate not in use
Set BitFile = fso.CreateTextFile("C:\FileLock.txt", True)
If SetLock = True Then
BitFile.WriteLine "1"
Else
BitFile.WriteLine "0"
End If
BitFile.Close
End Sub

Related

MS Access: Upload multiple files from one button

I am trying to upload multiple files at once into an access database via the use of a button. However only one file will upload at a time.
When the button is clicked it calls a sub procedure. My code is below:
Private Sub btnImport_Click()
'Calls the procdure that imports raw files
Call Module1.ImportRawFiles
End Sub
Public Sub ImportRawFiles()
Dim oFileDiag As Office.FileDialog
Dim path As String: path = ""
Dim oFSO As New FileSystemObject
Dim FileSelected As Variant
Set oFileDiag = Application.FileDialog(msoFileDialogFilePicker) ''Picks file to import
oFileDiag.AllowMultiSelect = True ''Allows multiple files to be selected
oFileDiag.Title = "Please select the reports to upload"
oFileDiag.Filters.Clear
oFileDiag.Filters.Add "Excel Spreadsheets", "*.xlsx, *.xls" ''Only allows xlsx and xls file types to upload
If oFileDiag.Show Then
For Each FileSelected In oFileDiag.SelectedItems
Form_Homepage.txtFileName = FileSelected
Next
End If
If Nz(Form_Homepage.txtFileName, "") = "" Then
MsgBox "No files selected please select a file"
Exit Sub
End If
If oFileDiag.SelectedItems.Count > 0 Then path = oFileDiag.SelectedItems(1)
If Len(path) > 0 Then
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, oFSO.GetFileName(Form_Homepage.txtFileName), path, 1
MsgBox "The " & oFSO.GetFileName(Form_Homepage.txtFileName) & " file has been uploaded"
Else
MsgBox "File not found"
End If
Does anyone know why only one file is uploading?
You are looping through all selected files to assign Form_Homepage.txtFileName but then not doing anything else in that same loop:
If oFileDiag.Show Then
For Each FileSelected In oFileDiag.SelectedItems
Form_Homepage.txtFileName = FileSelected
Next
End If
So by end of the loop, the last selected file is assigned, ignoring all the others, then your later logic statements only perform on that one file.
One solution would be to move your action logic up to the same loop. So move your IF statements into the assignment loop, that way they operate on each iterative assignment of your variable.

MSAccess crashes opening a file

I am using Office 365 on a windows 10 PC.
I have some VBA code in Access to check whether a file is open or locked (the file is local to this PC).
On one computer this code runs for most files, but consistently crashes when it reaches a particular set of files. It is the same set of files each time if I manually step through the code to move on from the first file. I tried rebooting the PC to clear any locks, but the result is the same.
When I say crash, I mean that I loose control of Access and windows reports that it is no longer responding.
If I run the same code on a different PC, referring to the same files, it reports the file is locked, but does not crash.
The file is not locked, or not in the way I understand file locking. From the user interface, I can rename, move or delete the files at will.
I am fairly certain there is nothing wrong with the VBA code as written and am beginning to think there may be a corrupt DLL somewhere.
VBA references
My code crashes at the line Open my_source For Input Lock Read As #ff
Function copyormovemyfiles(my_source As String, my_dest As String, mycontrol As Integer) As Boolean
Dim fso As Scripting.FileSystemObject
Dim ff As Long, ErrNo As Long
''''''''''''''''
' mycontrol = 1 for a move
' mycontrol = 2 for a copy. It will not overwrite files
''''''''''''''''
On Error GoTo error_control
Set fso = New Scripting.FileSystemObject
If Not fso.FileExists(my_source) Then
Err.Raise 1000, , my_source & " does not exist!" & vbExclamation & "Source File Missing"
ElseIf Not fso.FileExists(my_dest) Then
fso.CopyFile my_source, my_dest, True
Else
Err.Raise 1000, my_dest & " already exists!" & vbExclamation
End If
Select Case mycontrol
Case 1
On Error Resume Next
ff = FreeFile()
Open my_source For Input Lock Read As #ff
Close ff
ErrNo = Err
'On Error GoTo 0
If ErrNo > 0 Then Stop
Err.Clear
'Select Case ErrNo
'Case 0: IsWorkBookOpen = False
'Case 70: IsWorkBookOpen = True
'Case Else: Error ErrNo
'End Select
On Error GoTo error_control
It's best to just do an action and then deal with the fail case instead of testing beforehand. The reason is that the state could change between your test and the action. Also, you are raising errors manually when you can just let your code raise it's errors organically.
So you say your copy won't overwrite but then you tell the copy command to overwrite. If we tell it not to overwrite then we no longer have to test if the source or destination exist, they both result in clear errors.
NOTE: Don't use underscore "_" in variable or function names because those are used for event definitions in the VBA event handler.
Function copyormovemyfiles(my_source As String, my_dest As String, mycontrol As Integer) As Boolean
''''''''''''''''
' mycontrol = 1 for a move
' mycontrol = 2 for a copy. It will not overwrite files
''''''''''''''''
On Error GoTo error_control
Dim fso As Scripting.FileSystemObject
fso.CopyFile my_source, my_dest, overwrite:=False
If mycontrol = 1 Then
SetAttr my_source, vbNormal
fso.DeleteFile my_source
End If
copyormovemyfiles = True
error_control:
If Err.Number <> 0 Then
' You can select case here and handle the error
copyormovemyfiles = False
End If
End Function

Change the default caption of a label with MS Access VBA

I have a label on my MS Access main form that needs to display the save location of an export file. I have an [Edit] button that when clicked brings up a file dialog box and allows the user to select a folder to export to. Once the folder is selected the label caption changes to the location of the folder that the user selected. This works excellently. My only issue, is that when the DB is closed and reopened the label caption is back to whatever the original caption was (in this instance lets say it just says TEST). I would like to have it so that when the label caption is changed, it stays that way unless the user clicks the [Edit] button and changes the location again. Below is the VBA code that I am using.
Thank you in advance for your help!
Sub SetFileLocation()
Dim Ret
strUserName = Environ("UserName")
strPath = "C:\documents and settings\" & strUserName & "\Desktop"
'~~> Specify your start folder here
Ret = BrowseForFolder(strPath)
Forms.frmmainform.lblFolderLocation.Caption = strFolderLocation
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Debug.Print BrowseForFolder
strFolderLocation = BrowseForFolder
Debug.Print strFolderLocation
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
Although best way is storing value in some table you can save previous value in custom form property.
First create a form property (in immediate window):
CurrentProject.AllForms ("Your form name").Properties.Add "LastFolder", ""
Then save it in your sub like that
...
Me.lblFolderLocation.Caption = strFolderLocation
CurrentProject.AllForms("Your form name").Properties("LastFolder").Value = strFolderLocation
Then restore last value in Load event:
Private Sub Form_Load()
Me.lblFolderLocation.Caption = CurrentProject.AllForms("Your form name").Properties("LastFolder")
End Sub

Error 53 when opening CSV file on mac

When I try and open a CSV file, I get:
Error 53: File not found
I get the error on the 4th line, Open FilePath For Input As #1
What am I doing wrong?
It is my first time opening a CSV, please be indulgent with my code.
Sub opentextfile()
Dim FilePath As String
FilePath = "/Users/christinekelly/Desktop/authors.csv"
file1 = FreeFile
Open FilePath For Input As #file1
row_number = 0
Do Until EOF(1)
Line Input #file1, LineFromFile
LineItems = Split(LineFromFile, ",")
ActiveCell.Offset(row_number, 0).Value = LineItems(2)
ActiveCell.Offset(row_number, 1).Value = LineItems(1)
ActiveCell.Offset(row_number, 2).Value = LineItems(0)
Number = row_number + 1
Loop
Close #file1
End Sub
So from looking at #Rebekare's answer to this question this is what worked for me.
I went to the file in question test.csv and opened the immediate window and typed ?ThisWorkbook.Path and got HDD:Users:USER:Desktop.
I then used the suggested concatenatation of this path with Application.PathSeparator & filename i.e.
FilePath = "HDD:Users:USER:Desktop" & Application.PathSeparator & "test.csv"
This is a useful approach as you get the actual file path syntax and then yield the path separator decision to the Application.
Following on from #Mat'sMug suggestion, I found this, which opens the file dialog, and you select the file you want the full path of and it is returned via the message box.
Sub PathofFile()
OpenFile = Application.GetOpenFilename()
MsgBox OpenFile
End Sub
Within that same link was a suggestion for using the Dir function to test if the filepath is valid. If valid you get the filename back, if not you get an error which you can use to determine your next action e.g. the following returns "test.csv" if it exists at that filepath.
MsgBox Dir("HDD:Users:USER:Desktop:test.csv")
If you are doing other operations with the file you might want to add a test to to see if the file is open first, using Microsoft's IsFileOpen function. An example as follows:
Sub Test
If Not IsFileOpen(FilePath) Then
Set wb = Workbooks.Open(FilePath)
End If
End Sub
Function IsFileOpen(filename As String)
Dim filenum As Integer, errnum As Integer
On Error Resume Next ' Turn error checking off.
filenum = FreeFile() ' Get a free file number.
' Attempt to open the file and lock it.
Open filename For Input Lock Read As #filenum
Close filenum ' Close the file.
errnum = Err ' Save the error number that occurred.
On Error GoTo 0 ' Turn error checking back on.
' Check to see which error occurred.
Select Case errnum
' No error occurred.
' File is NOT already open by another user.
Case 0
IsFileOpen = False
' Error number for "Permission Denied."
' File is already opened by another user.
Case 70
IsFileOpen = True
' Another error occurred.
Case Else
Error errnum
End Select
End Function

VBA Excel - Macro tells me Word Document is Open even though it is not open

To start off I have a function in VBA Excel that tells me if a Word Document is open or not open. For testing purposes I don't have the Word Document Open and expect 'False' to be returned.
Function IsFileOpen(filename As String) As Boolean
Dim filenum As Integer, errnum As Integer
On Error Resume Next ' Turn error checking off.
filenum = FreeFile() ' Get a free file number.
' Attempt to open the file and lock it.
Open filename For Input Lock Read As #filenum
Close filenum ' Close the file.
errnum = Err ' Save the error number that occurred.
On Error GoTo 0 ' Turn error checking back on.
' Check to see which error occurred.
Select Case errnum
' No error occurred.
' File is NOT already open by another user.
Case 0
IsFileOpen = False
' Error number for "Permission Denied."
' File is already opened by another user.
Case 70
IsFileOpen = True
' Another error occurred.
Case Else
Error errnum
End Select
End Function
Called Via:
...
If IsFileOpen("C:/Temp/test.docx") = True Then
MsgBox objWord.ActiveDocument.Name & " already open" 'ERROR FROM PIC HERE
Set objDoc = objWord.ActiveDocument
Else
Set objDoc = objWord.Documents.Open("C:/Temp/test.docx", Visible:=True)
End If
...
However when running the code I get that the Document is open (Returned True from the IsFileOpen function from case 70) yet I get an error on 'objWord.ActiveDocument.Name' that no Document is Open
On Windows 7 Task Manager this is what I have. Word Application is closed but it appears there are background processes open of Word. However I close all documents I don't use so these processes shouldn't be running
I think a better test to check to see if your Word File is open is to use the actual Word Documents collection
So for your example, use something like this:
With objWord
For Each doc In .Documents
If doc.Name = "test.docx" Then
found = True
Exit For
End If
Next doc
If found <> True Then
.Documents.Open FileName:="C:/Temp/test.docx"
Else
.Documents("test.docx").Activate
End If
End With