I am currently experiencing an Issue with the On.Time() Command.
The Ontime offsetvalue is set to 00:00:10 checking if Files are open. (Sort of a realtime checker).
Sub MacroAutoRun1()
Dim RunTime1 As Date
RunTime1 = Now + TimeValue("00:10:00")
Application.OnTime RunTime1, "MacroAutoRun1"
If IsFileOpen("H:\Operations_Front_Office\Organisation Helpdesk & Renseignement\Test\1\Statistik.xlsm") Then
Interface.Interface_Statistik_Open_Val.Caption = "File in use"
Else
Interface.Interface_Statistik_Open_Val.Caption = "File currently not used"
End If
If IsFileOpen("H:\Operations_Front_Office\Organisation Helpdesk & Renseignement\Test\1\Timesheet.xlsm") Then
Interface.Interface_Timesheet_Open_Val.Caption = "File in use"
Else
Interface.Interface_Timesheet_Open_Val.Caption = "File currently not used"
End If
If IsFileOpen("H:\Operations_Front_Office\Organisation Helpdesk & Renseignement\Test\1\Datasheet_Roulement_Final_Original.xlsm") Then
Interface.Interface_Roulement_Open_Val.Caption = "File in use"
Else
Interface.Interface_Roulement_Open_Val.Caption = "File currently not used"
End If
IsFileOpen is a created function as per below:
Function IsFileOpen(FileName As String)
Dim iFilenum As Long
Dim iErr As Long
On Error Resume Next
iFilenum = FreeFile()
Open FileName For Input Lock Read As #iFilenum
Close iFilenum
iErr = Err
On Error GoTo 0
Select Case iErr
Case 0: IsFileOpen = False
Case 70: IsFileOpen = True
Case Else: Error iErr
End Select
End Function
My Problem now is that while doing the check it seems other Procedures are not able to be completed such as:
If DateDfrHDSKMALADIE = 0 Then
Set FoundHDSKMaladie = Sheets("Congé + Maladie").Columns(1).Find(What:=Maladie1HDSKtxt, After:=Sheets("Congé + Maladie").Cells(1, 1))
X = FoundHDSKMaladie.Row
Y = FoundHDSKMaladie.Column + HDSKMALADIENumb
Sheets("Congé + Maladie").Cells(X, Y) = "M"
Then the FoundHDSKMaladie returns "Nothing" and it seems to me that the Find Method is not even applied.
Have you heard of such an issue? I would like to keep the search open in the Background (peferably), if that would not work I will then just revert to stopping the Timer when the Page is left and reactivate it when the User returns to the page.
Thanks in advance for your help.
I'm not sure why the method you are using are interuppting the other procedures, but I have used a similar things in the past using a workbook exists function. As the files that you are checking appear to be workbooks I'd suggest checking if using this function rather than the IsFileOpen function solves the issue. I beleive I saw this method in a excel/vba dummies book.
The string for the function would be "Statistik.xlsm" for example.
Function WorkbookExists(ByVal BookToCheck As String) As Boolean
Dim Path As String
On Error GoTo Find_Err
Path = Workbooks(BookToCheck).Saved
On Error GoTo 0
WorkbookExists = True
Exit Function
Find_Err:
WorkbookExists = False
End Function
Related
I am trying to install addins programmatically (more precisely, it is automated version update on Workbook_Open event) but I have run into an issue with the AddIns.Add method, which just "does not work". I copy the desired adding into C:\Users\[username]\Documents\Addins and then feed the full filepath to AddIns.Add, however the addin is not added, as evidenced by the subsequent statement failing (subscript out of range, the name of the supposedly added addin does not exist).
During the install attempt, the execution simply runs through the AddIns.Add without any issue (except the result) but on stepping through, I am getting Internal error (Error 51). I have tried a number of ways to work around that, add Application.Wait before and after the AddIns.Add to make sure it has sufficient time, putting it into a Do While Loop statement to attempt multiple executions, but to no avail.
AddIns.Add Filename:=sInstallPath & sFile
AddIns(sAddinFullName).Installed = True
Btw this worked until yesterday, when I did a couple codes updates but not even remotely close to this area. I think I had some issues with this in past because the statement was envelopped by Application.Wait (Now + TimeValue("0:00:01")), which I think resolved probably a similar issue but I cannot recall that any more.
Edit: Adding a broader part of the code - a function that does the installation proper and on success, returns True.
Function InstallAddin(sFullPath, sAddinName) As Boolean
Dim oAddin As Object
Dim bAdded As Boolean
Dim i As Integer
Do Until bAdded = True Or i = 10
For Each oAddin In AddIns
If oAddin.Name = sAddinName Then
bAdded = True
Exit For
End If
Next oAddin
If bAdded = False Then
'Application.Wait (Now + TimeValue("0:00:01"))
AddIns.Add Filename:=sFullPath, CopyFile:=False
Debug.Print "Attempt " & i
'Application.Wait (Now + TimeValue("0:00:01"))
End If
i = i + 1
Loop
If bAdded = True Then
'disable events to prevent recurrence - installing addin counts as opening its workbook
Application.EnableEvents = False
AddIns(sAddinName).Installed = True
Application.EnableEvents = True
InstallAddin = True
End If
End Function
sFullPath : "C:\Users\Eleshar\Documents\Addins\MyAddin - v.0.25.xlam"
sAddinName : "MyAddin - v.0.25"
The "MyAddin - v.0.25.xlam" file is present in the installation path.
There is a piece of code elsewhere, which ensures that a regular WB is open during this event.
Edit 2: The full functionality of the macro is:
On opening the file by a user, offering self-install.
On opening the file by a user, checking for previous installed versions, offering self-installation (after which it removes the old versions, including itself).
On Workbook_Open, checking a Sharepoint repository for any new versions, offering to install the newest one available and removing any older versions including itself.
Edit 3: So I found an interesting thing... AddIns.Add does not seem to work when executed from the code (the addin does not get listed in Developer > Addins). However when I type the same exact statement into the immediate window during the execution, it works and then the addin can get installed...
Since you do not show all your used code, please try the next one. I am using it to auto install the add-ins I design:
Private Sub Workbook_Open()
Dim Name As String, tmp As Boolean, n As Boolean, Merk As String
Name = ThisWorkbook.BuiltinDocumentProperties(1) '(1)
On Error Resume Next
tmp = AddIns(Name).Installed
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
If Workbooks.Count = 0 Then n = True
If n Then
Workbooks.Add
Merk = ActiveWorkbook.Name
End If
AddIns.Add FileName:=ThisWorkbook.FullName
AddIns(Name).Installed = True
If n Then Workbooks(Merk).Close False
End If
On Error GoTo 0
End Sub
'(1) it represents the Add-inn title. It can be set programmatically or manual in Properties - Details - Title. When add-in is not open!
So I did not really figure out the issue with AddIns.Add, however I worked around that but having the macro directly edit the Excel registry keys to install the add in.
Sub AddinInstall(sAddinName As String, ByVal sFullPath As String)
Dim oShell As Object: Set oShell = CreateObject("WScript.Shell")
Dim i As Integer: i = 0
Dim iIndex As Integer
Dim sRegKey As String: sRegKey = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Office\16.0\Excel\Options\OPEN"
Dim sSZ As String
sFullPath = ChrW(34) & sFullPath & ChrW(34)
On Error Resume Next
Do 'loop through registry keys (non-existent key results in error, so errors must be disabled) to find if lower version is installed
i = i + 1
sSZ = ""
sSZ = oShell.RegRead(sRegKey & CStr(i))
If Len(sSZ) > 0 Then
If sSZ Like "*" & sAddinName & "*" Then
Debug.Print sSZ
iIndex = i 'get number at the end of registry key name
End If
End If
Loop Until Len(sSZ) = 0
If iIndex > 0 Then 'previous version installed - overwrite
oShell.RegWrite sRegKey & CStr(iIndex), sFullPath, "REG_SZ"
Else 'previous version not found, create new registry key
oShell.RegWrite sRegKey & CStr(i), sFullPath, "REG_SZ"
End If
On Error GoTo 0
End Sub
I'm mapping to the company's sharepoint drive using VBA. The intention is to save local file to sharepoint, and delete local file and unmapped the drive after success.
On my machine(Windows 10 64bits), the code works perfectly fine, successfully mapped the drive, created folder and file, successfully uploaded to sharepoint and unmap the drive.
However, when I run the same excel workbook that contains the same code on my colleague's computer(Window 7), it failed. There's no error being shown, except that it keeps on loading and loading until Excel Not Responsive. I tried manually mapping the drive, it success.
I tried to debug and found out that the code stops (keeps on loading) at MsgBox "Hello" but could not figure out what's missing.
Both are using Excel 2016
Any help and suggestions are appreciated. let me know if more info is needed. Thanks in advance.
This is my vba code
Sub imgClicked()
Dim fileName As String
Dim SharePointLib As String
Dim MyPath As String
Dim folderPath As String
Dim objNet As Object
Dim copyPath As String
Dim copyFilePath As String
folderPath = Application.ThisWorkbook.path
MyPath = Application.ThisWorkbook.FullName
Dim objFSO As Object
Dim strMappedDriveLetter As String
Dim strPath As String
Dim spPath As String
strPath = "https://company.com/sites/test/test 123/" 'example path
spPath = AvailableDriveLetter + ":\test.xlsm" 'example path
copyPath = folderPath + "\copyPath\"
'Add reference if missing
Call AddReference
Set objFSO = CreateObject("Scripting.FileSystemObject")
With objFSO
strMappedDriveLetter = IsAlreadyMapped(.GetParentFolderName(strPath))
If Not Len(strMappedDriveLetter) > 0 Then
strMappedDriveLetter = AvailableDriveLetter
If Not MapDrive(strMappedDriveLetter, .GetParentFolderName(strPath)) Then
MsgBox "Failed to map SharePoint directory", vbInformation, "Drive Mapping Failure"
Exit Sub
End If
End If
' Check file/folder path If statement here
End With
Set objFSO = Nothing
End Sub
Code for getting available drive
' Returns the available drive letter starting from Z
Public Function AvailableDriveLetter() As String
' Returns the last available (unmapped) drive letter, working backwards from Z:
Dim objFSO As Object
Dim i As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
For i = Asc("Z") To Asc("A") Step -1
Select Case objFSO.DriveExists(Chr(i))
Case True
Case False
Select Case Chr(i)
Case "C", "D" ' Not actually necessary - .DriveExists should return True anyway...
Case Else
AvailableDriveLetter = Chr(i)
Exit For
End Select
End Select
Next i
Set objFSO = Nothing
MsgBox "This is the next available drive: " + AvailableDriveLetter ' returns Z drive
MsgBox "Hello" ' After this msgBox, starts loading until Not Responsive
End Function
Function to Map drive
Public Function MapDrive(strDriveLetter As String, strDrivePath As String) As Boolean
Dim objNetwork As Object
If Len(IsAlreadyMapped(strDrivePath)) > 0 Then Exit Function
Set objNetwork = CreateObject("WScript.Network")
objNetwork.MapNetworkDrive strDriveLetter & ":", strDrivePath, False
MapDrive = True
MsgBox "Successfully Created the Drive!"
Set objNetwork = Nothing
End Function
Code for MappedDrive
Public Function GetMappedDrives() As Variant
' Returns a 2-D array of (1) drive letters and (2) network paths of all mapped drives on the users machine
Dim objFSO As Object
Dim objDrive As Object
Dim arrMappedDrives() As Variant
Dim i As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim arrMappedDrives(1 To 2, 1 To 1)
For i = Asc("A") To Asc("Z")
If objFSO.DriveExists(Chr(i)) Then
Set objDrive = objFSO.GetDrive(Chr(i))
If Not IsEmpty(arrMappedDrives(1, UBound(arrMappedDrives, 2))) Then
ReDim Preserve arrMappedDrives(1 To 2, 1 To UBound(arrMappedDrives, 2) + 1)
End If
arrMappedDrives(1, UBound(arrMappedDrives, 2)) = Chr(i) ' Could also use objDrive.DriveLetter...
arrMappedDrives(2, UBound(arrMappedDrives, 2)) = objDrive.ShareName
End If
Next i
GetMappedDrives = arrMappedDrives
Set objDrive = Nothing
Set objFSO = Nothing
End Function
Public Function IsAlreadyMapped(strPath As String) As String
' Tests if a given network path is already mapped on the users machine
' (Returns corresponding drive letter or ZLS if not found)
Dim strMappedDrives() As Variant
Dim i As Long
strMappedDrives = GetMappedDrives
For i = LBound(strMappedDrives, 2) To UBound(strMappedDrives, 2)
If LCase(strMappedDrives(2, i)) Like LCase(strPath) Then
IsAlreadyMapped = strMappedDrives(1, i)
Exit For
End If
Next i
Set objNetwork = Nothing
End Function
Add Reference
Sub AddReference()
'Macro purpose: To add a reference to the project using the GUID for the
'reference library
Dim strGUID As String, theRef As Variant, i As Long
'Update the GUID you need below.
strGUID = "{420B2830-E718-11CF-893D-00A0C9054228}"
'Set to continue in case of error
On Error Resume Next
'Remove any missing references
For i = ThisWorkbook.VBProject.References.Count To 1 Step -1
Set theRef = ThisWorkbook.VBProject.References.Item(i)
If theRef.isbroken = True Then
ThisWorkbook.VBProject.References.Remove theRef
End If
Next i
'Clear any errors so that error trapping for GUID additions can be evaluated
Err.Clear
'Add the reference
ThisWorkbook.VBProject.References.AddFromGuid _
GUID:=strGUID, Major:=1, Minor:=0
'If an error was encountered, inform the user
Select Case Err.Number
Case Is = 32813
'Reference already in use. No action necessary
Case Is = vbNullString
'Reference added without issue
Case Else
'An unknown error was encountered, so alert the user
MsgBox "A problem was encountered trying to" & vbNewLine _
& "add or remove a reference in this file" & vbNewLine & "Please check the " _
& "references in your VBA project!", vbCritical + vbOKOnly, "Error!"
End Select
On Error GoTo 0
End Sub
Procedure imgClicked is calling function AvailableDriveLetter multiple times. Remember that the function has to execute each time you refer to it.
I ran imgClicked (assuming that's the procedure you start with) and I was told, twice, "Next available letter = Z" and "Hello" and then it crashed Excel (perhaps getting stuck in a loop of creating FileSystem objects to look for an available drive letter?)
Try assigning AvailableDriveLetter to a variable (string) at the beginning of the procedure and referring to the variable each time you need the value, and see if you still have the issue.
(Remember to save before execution -- I get frustrated when troubleshooting "application hanging" issues because I keep forgetting to save my changes and then lose them on the crash!)
If this doesn't work, add a breakpoint (F9) on the End Function line after your "Hello" box and see if the code stops there. (I have trouble believing the MsgBox or End Function are the culprit.) If not, which procedure runs after that?
One more thing whether the issue is resolved or not:
Add Option Explicit at the very beginning of your module and then Compile the project and fix your missing variable declaration(s).
This is recommended whenever troubleshooting an issue as a means to eliminate variable declaration issues as a possible cause.
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
I want to catch my error handling statement only once, if it fails again, resume next. I'm not sure how to achieve that but so far i'm able to rerun the code if it keeps on failing. Reason is i don't want to get stuck in a loop if the file never exist. Here's what i have:
....some code
TryAgain:
....
....
If Not FileExists("C:\" & FileName) Then
GoTo TryAgain >>> Only want to run this once if it fails again continue on down with the next section of codes.
End If
....next code stuff....
.....Dim blnRetry as Boolean
blnRetry =true
TryAgain:
....
....
If Not FileExists("C:\" & FileName) Then
if blnRetry then
blnRetry=false
GoTo TryAgain
end if
End If
My rule about GoTo is that I only use it in an On Error statement. Consider using a Do..Loop and a counter. Here's an example
Sub Test()
Dim sFile As String
Dim lTryCnt As Long
Const lMAXTRYCNT As Long = 10
Do
sFile = InputBox("Enter file name")
lTryCnt = lTryCnt + 1
Loop Until sFile = "False" Or Len(Dir("C:\" & sFile)) > 0 Or lTryCnt >= lMAXTRYCNT
Debug.Print sFile, lTryCnt
End Sub
sfile = "False" is if the user clicks Cancel on the inputbox. Len(Dir()) returns a zero length string if the file doesn't exist.
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