AddIns.Add statement throwing an Internal Error 51 - vba

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

Related

Download file using VBA for Mac Word 2016

I am trying to update a template for Word 2016 for Mac.
In the prior code, I was able to run MacScript() command to run an AppleScript that in turn ran a shell script.
It appears the only way now to run such a script is to use AppleScriptTask, which requires that the script exists already in Application Scripts folder, which presents problems when I'm trying to distribute this to other (non-savvy) users.
I'm trying to figure out alternative ways of doing this, but after weeks of research, I am still stumped.
The scripts I'm running do various things, but the most important right now is to download updated versions of the template from a website. I use ActiveX on the Windows side to do this, but can't do that on Mac.
Can anyone suggest any alternative approaches for Mac Word 2016, using VBA (only preferably)?
Thank you!
Try this:
ActiveDocument.FollowHyperlink "http://yoursite.com/yourpackage.zip"
Below is what I did to accomplish this. I set a timer to wait on the download, since it's being done outside of VBA.
Function Download(Path As String) As String
On Error GoTo Handler
Dim User, UserPath, dlFile, base_dest, final_dest, FName As String
Dim Timer As Boolean
Timer = False
Dim timeout As Variant
timeout = Now + TimeValue("00:00:10")
User = Environ("USER")
UserPath = "/Users/" & User & "/Downloads/"
base_dest = "/Users/" & User & [move/path/]
final_dest = base_dest & FName
ActiveDocument.FollowHyperlink Address:=Path
If Dir(final_dest) <> "" Then
Kill final_dest
End If
Timer = True
ReTry:
If Dir(dlFile) <> "" Then
FileCopy dlFile, final_dest
Kill dlFile
Download = final_dest
Exit Function
End If
Handler:
If Err.Number = 53 And Timer = False Then
Resume Next
ElseIf Err.Number = 53 And Timer = True Then
If Now > timeout Then
MsgBox "There is a problem downloading the file. Please check your internet connection."
End
Else
Resume ReTry
End If
Else
MsgBox Err.Number & vbNewLine & Err.Description
End
End If
End Function

VBA - Unable to map drive to sharepoint on another computer

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.

VBA Word: remove editing restriction at opening and restrict again when closing

Is it possible to set a macro that would trigger each time I open a word document and check if it has an editing restriction. If so, try password from a list of passwords (hardcoded). In case one password is successfull, keep it in memory, remove restriction, and re-apply the restriction when I close the document.
In this way, if I always use the same password for the documents I use and restrict, I could open them on my computer as if there was no restriction, but the restriction would still apply to other users.
Note: the macro in Private Sub Document_Open() would need to trigger on all documents I open from my computer only. Documents must be .docx and not .docm.
Thank you.
Note 1: You will need to put this into a .dotm file and ultimately save as a global template on your PC (google).
Note 2: This will fail if you open more than 1 doc because only 1 password is stored - you could write the password as a document property (which you would retrieve & delete before saving and relocking).
Depending on whether or not you are happy to add code to the Normal.dotm template (personally I'm not) will influence how you do this.
If NOT using Normal.dotm then you will need to setup a global template AND trigger the code by creating your own application events as described here: https://wordmvp.com/FAQs/MacrosVBA/PseudoAutoMacros.htm
If using Normal.dotm then in ThisDocument add:
Private Sub Document_Open()
MsgBox ActiveDocument.Name
Dim oDoc As Object
Set oDoc = ActiveDocument
unlocker oDoc
End Sub
And (for testing) in a regular module add the following (you'll likely want to split this into separate units of code later):
Sub unlocker(ByVal docToUnlock As Document)
If Not docToUnlock.Type = wdTypeDocument Then
' this is a template, don't try anything
MsgBox "Not a doc"
GoTo endOfSub
Else
MsgBox "Is a doc"
End If
Dim passWords() As String
passWords = Split("pw1,pw2,pw3", ",")
Dim iLoop As Long
iLoop = LBound(passWords)
On Error GoTo err_Test:
Do While Not ActiveDocument.ProtectionType = wdNoProtection
If iLoop > UBound(passWords) Then Exit Do
oldpassword = passWords(iLoop)
ActiveDocument.Unprotect oldpassword
iLoop = iLoop + 1
Loop
If Not ActiveDocument.ProtectionType = wdNoProtection Then
' unable to unlock document, quit
oldpassword = vbNullString
MsgBox "Failed to Unlock"
GoTo endOfSub
Else
MsgBox "Unlocked"
End If
' Do Stuff
If Not oldpassword = vbNullString Then
ActiveDocument.Protect wdAllowOnlyReading, Password:=oldpassword
End If
endOfSub:
Exit Sub
err_Test:
If Err.Number = 5485 Then
' ignore error due to wrong password
Err.Clear
Resume Next
Else
' handle unexpected error
End If
End Sub

Excel VBA: How to implement timer to check for code timeout

I have some code that runs on workbook open that uses a form to request that the user select the drive to which a shared directory is mapped.
This is because the workbook uses VBA code to retrieve and save data to a shared workbook located in this shared directory, but the local drive changes by user, so they need to select it.
The problem I've run into occurs when the user has mapped multiple shared directories to their computer and thus have multiple drives... ex: 1 directory is on drive G: and the other is on X:.
If they select the drive for the shared directory in which the workbook resides, there is no problem. However, if they accidentally choose the drive for the other shared directory, the code hangs.
I have a loop setup that checks to see they've chosen the correct drive... IE: If they chose A: (a non-existent drive in my example), then the code will note that they chose the incorrect drive and prompt them again.
However, instead of creating an error when another shared directory is chosen, the code just hangs.
In the below code, cell AD3 on sheet one contains true or false (gets set to false in the beginning of the sub). It gets set to true if they've chosen correct drive as Module6.PipelineRefresh will no longer cause an error (this sub attempts to open the workbook in the shared drive... and if the chosen drive is incorrect it obviously returns an error)
Codes is as below:
Do While Sheet1.Range("ad3") = False
On Error Resume Next
Call Module6.PipelineRefresh '~~ I'm guessing the code hangs here. Instead of returning an error immediately, as it would if they simply chose a non-existant drive, it appears to get stuck trying to open the workbook, even though it's not located in the shared directory they've selected.
If Err.Number = 0 Then
Sheet1.Range("ad3") = True
Err.Clear
Else
MsgBox "Invalid Network Drive."
DriverSelectForm.Show
Err.Clear
End If
Loop
If anyone knows how to implement a timer so I can shutdown the code after some amount of time, that'd be great.
Alternatively, if you know how to get around this error, that'd also be great!
EDIT as per comment:
This is the specific code in Module6.PipelineRefresh that hangs. The DriverSelectForm (shown above) amends the value in cell o1 to the chosen drive string (ie: X:)
Dim xlo As New Excel.Application
Dim xlw As New Excel.Workbook
Dim xlz As String
xlz = Sheet1.Range("o1").Value & "\Region Planning\Created Pipeline.xlsx"
Dim WS As Worksheet
Dim PT As PivotTable
Application.DisplayAlerts = False
Set xlw = xlo.Workbooks.Open(xlz)
Application.DisplayAlerts = True
Note: As stated above, if the user selects a non-existent directory, the above code returns an error immediately because it cannot open the file... if they have a shared directory mapped to the chosen drive (but it's the wrong directory), the code will hang and does not appear to return an error.
I've answered my own question by working around the problem. Instead of checking that the user has selected the correct drive letter, I am now using the CreatObject function to find the drive letter associated with the drive name (as drive name will not change).
Example code for this:
Dim objDrv As Object
Dim DriveLtr As String
For Each objDrv In CreateObject("Scripting.FileSystemObject").Drives
If objDrv.ShareName = "Shared Drive Name" Then
DriveLtr = objDrv.DriveLetter
End If
Next
If Not DriveLtr = "" Then
MsgBox DriveLtr & ":"
Else
MsgBox "Not Found"
End If
Set objDrv = Nothing
The solution to stop some code by timer. The code must be placed in a module.
Private m_stop As Boolean
Sub stop_timer(p_start_time As Variant)
Application.OnTime p_start_time, "stop_loop"
End Sub
Sub signal_timer(p_start_time As Variant)
Application.OnTime p_start_time, "signal_in_loop"
End Sub
Sub test_loop()
Dim v_cntr As Long
m_stop = False
v_cntr = 0
stop_timer Now + TimeValue("00:00:05")
signal_in_loop
While Not m_stop
v_cntr = v_cntr + 1
DoEvents
Wend
Debug.Print "Counter:", v_cntr
End Sub
Sub stop_loop()
m_stop = True
End Sub
Sub signal_in_loop()
Debug.Print "timer:", Timer
If Not m_stop Then
signal_timer Now + TimeValue("00:00:01")
End If
End Sub
Output:
timer: 50191.92
timer: 50192
timer: 50193
timer: 50194
timer: 50195
timer: 50196
Counter: 67062
timer: 50197.05
m_stop controls the loop. DoEvents calls event handlers such as stop_loop and signal_in_loop as defered procedures.

VBA On.Time() Background Check in Combination with regular Usage

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