How to enter a KNOWN password for an addin from another addin

[crewaustin66]

Let me be clear that I know the password and can enter it when I click the project and get in fine. I just need to be able to do this from VBA code. Here's why.

I'm using VBE to write the addin's source code to a flat file for use in a source comparison app. You can't read the project code, change the project name, or anything if the addin protected. Manually unlocking it and running my code (kicked off from a ribbon bar button) does work. I've seen folks' attempts at this with SendKeys (ugh!) and smarter ones with windows api calls and SendMessage but it doesn't appear to work in newer versions of Excel (2013, at least, on up).

Does anyone have a solution to this?

Thanks,
-Crew

 

[Jeffrey Mahoney]

I've had some luck with this Chip Pearson code. You can read the description of how it works in the first SUB. It basically sets a custom named property in the Excel Window for later retrieval.

Calling the functions are as easy as this:

If GetProperty("Name1") = 99887766 Then
  'Do Something
end if

Dim B as boolean
B = SetProperty("Name1", 0)     'Reset the value to zero

Option Private Module
Option Explicit


Option Compare Text
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modGetSetProps
' By Chip Pearson, www.cpearson.com, chip@cpearson.com
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' This module contains functions for adding and retrieving property values (Long
' data types) of a window, typically the Excel application's main window. These
' values will remain accessible even when the workbook that created them is closed.
' They will be accessible from any code in any workbook as long as the window exists.
' Usually, you will want to use the Excel main application window (the default for all
' procedures) to store the properties. These properties will persist until Excel closes.
'
' Note that the property can contain only Long data values.
'
' This module contains the following Public procedures (not including Private
' support procedures):
'
'       GetAllProperties - This populates an array of CPropType classes,
'                          one instance for each property retrieved.
'                          See the documentation in this procedure for
'                          details about calling it.
'   GetDesktopHandle - This function returns the handle of the Windows desktop.
'       GetProperty      - This procedure gets the value of the specified
'                          property.
'       RemoveProperty   - This procedure removes the property from the window's
'                          property list.
'       SetProperty      - This creates an new property or updates an existing
'                          property.
'       GetHWndOfForm    - This returns the HWnd of the UserForm that is passed
'                          in to the procedure. This is to be used if you are
'                          storing values in the UserForm window's property list.
'       GetNewCPropType  - This returns a New CPropType class instance. This
'                          procedure is intended to be used when calling these
'                          procedures for other VBProjects that reference this
'                          Project. If you import this module and the CPropType
'                          class into your project, you can create a new CPropType
'                          instance with the New keyword -- you don't need to
'                          use the GetNewCPropType function.
'
'       All of these procedures have an optional argument name HWnd. If this
'       argument is omitted or is <= 0, the properties are stored in the main
'       Excel application window's property list. If HWnd is included and is > 0,
'       the property  list for that window is used. If you want to store properties
'       in a UserForm's property list, you can call HWnd = GetHWndOfForm(UF:=YourFormName)
'       to retrieve the HWnd of the form, and pass this value in the HWnd parameter
'       to the various function to set or retrieve the property value.
'
' The following are the Private procedures that are used to support the Public
' procedures in this module. You don't need to access these Private procedures (that
' is why they are declared as Private). They are used to support the Public procedures.
'
'       IsArrayAllocated
'       IsArrayDynamic
'       IsArrayEmpty
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


    
Private Declare Function IsWindow Lib "user32" ( _
    ByVal HWnd As Long) As Long


Private Declare Function GetProp Lib "user32" Alias "GetPropA" ( _
    ByVal HWnd As Long, _
    ByVal lpString As String) As Long


Private Declare Function SetProp Lib "user32" Alias "SetPropA" ( _
    ByVal HWnd As Long, _
    ByVal lpString As String, _
    ByVal hData As Long) As Long


Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long


Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" ( _
    ByVal HWnd As Long, _
    ByVal lpString As String) As Long


Private Declare Function EnumProps Lib "user32.dll" Alias "EnumPropsA" ( _
    ByVal HWnd As Long, _
    ByVal lpEnumFunc As Long) As Long


''''''''''''''''''''''''''''''''''''''''''''''''
' Note: The Visual Studio 6 API Viewer program
' shows the lpString type as String, not Long.
' It is incorrect.  lpString needs to be a Long.
''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare Function LStrLen Lib "kernel32" Alias "lstrlenA" ( _
    ByVal lpString As Long) As Long
    
''''''''''''''''''''''''''''''''''''''''''''''''
' Note: The Visual Studio 6 API Viewer program
' shows the lpString2 type as String, not Long.
' It is incorrect.  lpString2 needs to be a Long.
''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare Function LStrCpy Lib "kernel32.dll" Alias "lstrcpyA" ( _
      ByVal lpString1 As String, _
      ByVal lpString2 As Long) As Long
    
''''''''''''''''''''''''''''''''''''''''
' These two variables are used with the
' GetAllProperties procedure. See the
' documentation in GetAllProperties
' for details.
''''''''''''''''''''''''''''''''''''''''
Private ArrayNdx As Long
Private ListAllArray() As CPropType


''''''''''''''''''''''''''''''''''''''''
' These two variables are used with the
' PropertyExists procedure. See the
' documentation in PropertyExists
' procedure for details.
''''''''''''''''''''''''''''''''''''''''
Private PropertyToFind As String
Private PropertyFound As Boolean














Public Function SetProperty(PropertyName As String, PropertyValue As Long, _
        Optional HWnd As Long = 0) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SetProperty
' This function adds a property entry named PropertyName with the value
' PropertyValue to the window indentified by HWnd. If HWnd is omitted or
' <= 0, it is added to the main Excel application window's property list.
' The function returns True if the operation was successful, or False
' if an error occurred.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Res As Long
Dim DestHWnd As Long


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' If HWnd was omitted or <= 0, use the Excel main application
' window HWnd.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If HWnd <= 0 Then
    DestHWnd = FindWindow("XLMAIN", Application.Caption)
Else
    DestHWnd = HWnd
End If


If DestHWnd = 0 Then
    SetProperty = False
    Exit Function
End If


'''''''''''''''''''''''''''''''''''''''''''''
' Ensure PropertyName is not an empty string.
'''''''''''''''''''''''''''''''''''''''''''''
If Trim(PropertyName) = vbNullString Then
    SetProperty = False
    Exit Function
End If


'''''''''''''''''''''''''''''''''''''''''''''
' Ensure DestHWnd is an existing window.
'''''''''''''''''''''''''''''''''''''''''''''
If IsWindow(DestHWnd) = 0 Then
    SetProperty = False
    Exit Function
End If


Res = SetProp(HWnd:=DestHWnd, lpString:=PropertyName, hData:=PropertyValue)
If Res = 0 Then
    '''''''''''''''''''''
    ' An error occurred.
    '''''''''''''''''''''
    SetProperty = False
Else
    '''''''''''''''''''''
    ' Success.
    '''''''''''''''''''''
    SetProperty = True
End If


End Function










'Changed the code to return a long instead of TRUE or FALSE
Public Function GetProperty(PropertyName As String, Optional HWnd As Long = 0) As Long
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetProperty
' This function retrieves the value of PropertyName from
' the window specified by HWnd. If HWnd is omitted or <= 0,
' it looks in the main Excel application window's property
' list. It will return the value of the specified property
'
' The function returns zero or the value or the property
' if the operation was successful, or -1 if an error occurred.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Dim Res As Long
Dim DestHWnd As Long


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' If HWnd was omitted or is <= 0, use the Excel main application
' window HWnd.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If HWnd <= 0 Then
    DestHWnd = FindWindow("XLMAIN", Application.Caption)
Else
    DestHWnd = HWnd
End If


'''''''''''''''''''''''''''''''''''''''''''''
' Ensure DestHWnd is an existing window.
'''''''''''''''''''''''''''''''''''''''''''''
If IsWindow(DestHWnd) = 0 Then
    GetProperty = -1
    Exit Function
End If


'''''''''''''''''''''''''''''''''''''''''''''
' Ensure PropertyName is not an empty string.
'''''''''''''''''''''''''''''''''''''''''''''
If Trim(PropertyName) = vbNullString Then
    GetProperty = -1
    Exit Function
End If


Res = GetProp(DestHWnd, PropertyName)
'''''''''''''''''''''''''''''''''''''
' GetProp will return -1 if an error
' occurred, but 0 may also be a valid
' property value. Test Err.LastDllError
' to see if an error occurred. If it
' indicates an error, it is most likely
' that the property doesn't exist
' (Err.LastDllError = 2).
'''''''''''''''''''''''''''''''''''''
If Err.LastDllError <> 0 Then
    GetProperty = -1
Else
    'PropertyValue = Res
    GetProperty = Res
End If


End Function








Public Function GetDesktopHandle() As Long
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetDesktopHandle
' This returns the windows handle of the desktop window.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    GetDesktopHandle = GetDesktopWindow()
End Function


Public Function GetNewCPropType() As CPropType
''''''''''''''''''''''''''''''''''''''''''''''''
' GetNewCPropType
' This returns a new instance of CPropType to the
' calling procedure. This is to be used when you are
' calling these procedures from another VBAProject
' that references this project. If you import this
' module into the project, you can simply create
' a new class instance with the New keyword. E.g.,
'     Dim PT As CPropType
'     Set PT = New CPropType
' The Instancing property of CPropType is
' PublicNotCreatable, so another project can
' declare a variable of that type, but not create
' an instance of the class. This function creates
' and returns a new instance of CPropType. E.g.,
'
'     Dim PT As projGetSetProps.CPropType
'     Set PT = projGetSetProps.GetNewCPropType()
'
''''''''''''''''''''''''''''''''''''''''''''''''
    Set GetNewCPropType = New CPropType
End Function








Public Function GetAllProperties(ResultArray As Variant, _
    Optional HWnd As Long = 0) As Long
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetAllProperties
' This procedure creates an array in ResultArray, each element of which
' is an instance of the CPropType class, containing the name and value
' of each property in the property list of the window specified by HWnd.
' If HWnd is omitted or <= 0, the main Excel application window's property
' list is used.
'
' ResultArray must be a dynamic, one-dimensional array. The existing
' contents of ResultArray will be destroyed.
'
' The function returns the number of elements added to ResultArray,
' or -1 if an error occurred. The calling procedure should declare
' a dynamic array of CPropType classes, each of which will store the
' name and value of one property:
'
'        Dim PropArray() As CPropType
'
' It should then pass that array to this procedure:
'
'        Dim Res As Long
'        Res = GetAllProperties(ResultArray:=PropArray, HWnd:=0)
'
' This procedure will Erase and then repopulate ResultArray with instances
' of CPropType objects. Upon return from this procedure, the calling
' procedure should loop through the array:
'
'        If Res > 0 Then
'            ' One or more properties are stored in PropArray
'            For N = LBound(PropArray) To UBound(PropArray)
'                Debug.Print CStr(N), PropArray(N).Name, PropArray(N).Value
'            Next N
'        ElseIf Res = 0 Then
'            ' No properties were found for the specified window.
'            Debug.Print "No properties were found."
'        Else
'            ' An error occurred.
'            Debug.Print "An error occurred with GetAllProperties."
'        End If
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Dim Res As Long
Dim DestHWnd As Long
Dim Counter As Long
Dim Ndx As Long
Dim PT As CPropType


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' If HWnd was omitted or <= 0, use the Excel main application
' window HWnd.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If HWnd <= 0 Then
    DestHWnd = FindWindow("XLMAIN", Application.Caption)
Else
    DestHWnd = HWnd
End If


If DestHWnd = 0 Then
    GetAllProperties = -1
    Exit Function
End If


''''''''''''''''''''''''''''''''''
' Ensure ResultArray is an array.
''''''''''''''''''''''''''''''''''
If IsArray(ResultArray) = False Then
    GetAllProperties = -1
    Exit Function
End If


''''''''''''''''''''''''''''''''''
' Ensure ResultArray is dynamic.
''''''''''''''''''''''''''''''''''
If IsArrayDynamic(Arr:=ResultArray) = False Then
    GetAllProperties = -1
    Exit Function
End If


'''''''''''''''''''''''''''''''''''''''''''''
' Ensure DestHWnd is an existing window.
'''''''''''''''''''''''''''''''''''''''''''''
If IsWindow(DestHWnd) = 0 Then
    GetAllProperties = -1
    Exit Function
End If


'''''''''''''''''''''''''''''''''''''''''''''
' Erase the existing ListAllArray and set the
' ArrayNdx variable to 0. Erase the ResultArray
' so we can repopulate it with instances of
' CPropType. Erase the ListAllArray to start
' with a new set of class instances.
''''''''''''''''''''''''''''''''''''''''''''''
Erase ListAllArray
Erase ResultArray
ArrayNdx = 0
'''''''''''''''''''''''''''''''''''''''''''''''
' Call EnumProps to get all the properties of
' DestHWnd's property list. Windows will call
' ProcEnumPropForListAll for each property
' in the window's property list.
'''''''''''''''''''''''''''''''''''''''''''''''
Res = EnumProps(HWnd:=DestHWnd, lpEnumFunc:=AddressOf ProcEnumPropForListAll)
''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Redim the ResultArray to the number of properties
' enumerated by EnumProps. Copy the array ListAllArray
' to ResultArray.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If IsArrayAllocated(Arr:=ListAllArray) = True Then
    ReDim ResultArray(1 To UBound(ListAllArray))
    Set PT = New CPropType
    For Ndx = LBound(ListAllArray) To UBound(ListAllArray)
        Set PT = ListAllArray(Ndx)
        PT.Name = ListAllArray(Ndx).Name
        PT.Value = ListAllArray(Ndx).Value
        Set ResultArray(Ndx) = PT
    Next Ndx
End If
''''''''''''''''''''''''''''''''''''''''''''''''''
' If the array is allocated, we retrieved at least
' one property. Return the number of properties
' retrieved. If the array is not allocated, there
' were no properties to retrieve, so return 0.
''''''''''''''''''''''''''''''''''''''''''''''''''
If IsArrayAllocated(Arr:=ResultArray) = True Then
    GetAllProperties = UBound(ResultArray)
Else
    GetAllProperties = 0
End If




End Function












Public Function PropertyExists(PropertyName As String, _
    Optional HWnd As Long = 0) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' PropertyExists
' This function returns True or False indicating whether the
' property with the string value PropertyName exists for the
' window specified in HWnd. If HWnd is omitted or <= 0, the
' main Excel application window's property list is searched.
' The function returns True if the property exists or False
' if the property does not exist or an error occurred.
' It calls EnumProps to enumerate all the properties in
' the Propety List for HWnd, looking for a property whose
' name is the same as the value of PropertyName.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Res As Long
Dim DestHWnd As Long


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' If HWnd was omitted or <= 0, use the Excel main application
' window HWnd.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If HWnd <= 0 Then
    DestHWnd = FindWindow("XLMAIN", Application.Caption)
Else
    DestHWnd = HWnd
End If




'''''''''''''''''''''''''''''''''''''''''''''
' Ensure DestHWnd is an existing window.
'''''''''''''''''''''''''''''''''''''''''''''
If IsWindow(DestHWnd) = 0 Then
    PropertyExists = False
    Exit Function
End If


''''''''''''''''''''''''''''''''''''''''''''''''''
' Set PropetyFound to False and set PropertyToFind
' the the property name we're looking for.
''''''''''''''''''''''''''''''''''''''''''''''''''
PropertyFound = False
PropertyToFind = PropertyName


'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Call EnumProps, passing it the address of the
' ProcEnumPropForFind function. The ProcEnumPropForFind
' function will be called by Windows one time for each
' property in the window's property list.
' ProcEnumPropForFind will test the name of each property
' against PropertyToFind and if a match is found, it
' will set PropertyFound to True and terminate the
' enumeration.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
Res = EnumProps(DestHWnd, AddressOf ProcEnumPropForFind)


PropertyExists = PropertyFound


End Function




Public Function RemoveProperty(PropertyName As String, _
    Optional HWnd As Long = 0) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' RemoveProperty
' This function removes the property named by PropertyName from the property
' list of the window specified by HWnd. If HWnd is omitted or <= 0, then
' main Excel application window's property list is used.
' The function returns True if the operation was successful, or False if
' an error occurred.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Dim Res As Long
Dim DestHWnd As Long


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' If HWnd was omitted or <= 0, use the Excel main application
' window HWnd.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If HWnd <= 0 Then
    DestHWnd = FindWindow("XLMAIN", Application.Caption)
Else
    DestHWnd = HWnd
End If


'''''''''''''''''''''''''''''''''''''''''''''
' Ensure DestHWnd is an existing window.
'''''''''''''''''''''''''''''''''''''''''''''
If IsWindow(DestHWnd) = 0 Then
    RemoveProperty = False
    Exit Function
End If
'''''''''''''''''''''''''''''''''''''''''''''
' Ensure PropertyName is not an empty string.
'''''''''''''''''''''''''''''''''''''''''''''
If Trim(PropertyName) = vbNullString Then
    RemoveProperty = False
    Exit Function
End If


Res = RemoveProp(DestHWnd, PropertyName)
''''''''''''''''''''''''''''''''
' If PropertyName doesn't exist
' we'll get an error value in Res.
' We can safely ignore this error
' and return True.
''''''''''''''''''''''''''''''''
RemoveProperty = True
End Function


Public Function GetHWndOfForm(UF As Object) As Long
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetHWndOfForm
' This returns the HWnd of the UserForm referenced in UF.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim HWnd As Long
    HWnd = FindWindow("ThunderDFrame", UF.Caption)
    GetHWndOfForm = HWnd
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Private Support Procedures
' These functions are documented and available for download at
' http://www.cpearson.com/excel/vbaarrays.htm.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Private Function IsArrayAllocated(Arr As Variant) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' IsArrayAllocated
' Returns TRUE if the array is allocated (either a static array or a dynamic array that has been
' sized with Redim) or FALSE if the array is not allocated (a dynamic that has not yet
' been sized with Redim, or a dynamic array that has been Erased). Static arrays are always
' allocated.
'
' The VBA IsArray function indicates whether a variable is an array, but it does not
' distinguish between allocated and unallocated arrays. It will return TRUE for both
' allocated and unallocated arrays. This function tests whether the array has actually
' been allocated.
'
' This function is just the reverse of IsArrayEmpty.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Dim N As Long
On Error Resume Next


' if Arr is not an array, return FALSE and get out.
If IsArray(Arr) = False Then
    IsArrayAllocated = False
    Exit Function
End If


' Attempt to get the UBound of the array. If the array has not been allocated,
' an error will occur. Test Err.Number to see if an error occurred.
N = UBound(Arr, 1)
If (Err.Number = 0) Then
    ''''''''''''''''''''''''''''''''''''''
    ' Under some circumstances, if an array
    ' is not allocated, Err.Number will be
    ' 0. To acccomodate this case, we test
    ' whether LBound <= Ubound. If this
    ' is True, the array is allocated. Otherwise,
    ' the array is not allocated.
    '''''''''''''''''''''''''''''''''''''''
    If LBound(Arr) <= UBound(Arr) Then
        ' no error. array has been allocated.
        IsArrayAllocated = True
    Else
        IsArrayAllocated = False
    End If
Else
    ' error. unallocated array
    IsArrayAllocated = False
End If


End Function


Private Function IsArrayDynamic(ByRef Arr As Variant) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' IsArrayDynamic
' This function returns TRUE or FALSE indicating whether Arr is a dynamic array.
' Note that if you attempt to ReDim a static array in the same procedure in which it is
' declared, you'll get a compiler error and your code won't run at all.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Dim LUBound As Long


' If we weren't passed an array, get out now with a FALSE result
If IsArray(Arr) = False Then
    IsArrayDynamic = False
    Exit Function
End If


' If the array is empty, it hasn't been allocated yet, so we know
' it must be a dynamic array.
If IsArrayEmpty(Arr:=Arr) = True Then
    IsArrayDynamic = True
    Exit Function
End If


' Save the UBound of Arr.
' This value will be used to restore the original UBound if Arr
' is a single-dimensional dynamic array. Unused if Arr is multi-dimensional,
' or if Arr is a static array.
LUBound = UBound(Arr)


On Error Resume Next
Err.Clear


' Attempt to increase the UBound of Arr and test the value of Err.Number.
' If Arr is a static array, either single- or multi-dimensional, we'll get a
' C_ERR_ARRAY_IS_FIXED_OR_LOCKED error. In this case, return FALSE.
'
' If Arr is a single-dimensional dynamic array, we'll get C_ERR_NO_ERROR error.
'
' If Arr is a multi-dimensional dynamic array, we'll get a
' C_ERR_SUBSCRIPT_OUT_OF_RANGE error.
'
' For either C_NO_ERROR or C_ERR_SUBSCRIPT_OUT_OF_RANGE, return TRUE.
' For C_ERR_ARRAY_IS_FIXED_OR_LOCKED, return FALSE.


ReDim Preserve Arr(LBound(Arr) To LUBound + 1)


Select Case Err.Number
    Case 0
        ' We successfully increased the UBound of Arr.
        ' Do a ReDim Preserve to restore the original UBound.
        ReDim Preserve Arr(LBound(Arr) To LUBound)
        IsArrayDynamic = True
    Case 9
        ' Arr is a multi-dimensional dynamic array.
        ' Return True.
        IsArrayDynamic = True
    Case 10
        ' Arr is a static single- or multi-dimensional array.
        ' Return False
        IsArrayDynamic = False
    Case Else
        ' We should never get here.
        ' Some unexpected error occurred. Be safe and return False.
        IsArrayDynamic = False
End Select


End Function




Private Function IsArrayEmpty(Arr As Variant) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' IsArrayEmpty
' This function tests whether the array is empty (unallocated). Returns TRUE or FALSE.
'
' The VBA IsArray function indicates whether a variable is an array, but it does not
' distinguish between allocated and unallocated arrays. It will return TRUE for both
' allocated and unallocated arrays. This function tests whether the array has actually
' been allocated.
'
' This function is really the reverse of IsArrayAllocated.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Dim Var As Variant
Err.Clear
On Error Resume Next
If IsArray(Arr) = False Then
    ' we weren't passed an array, return True
    IsArrayEmpty = True
End If


' Attempt to get the UBound of the array. If the array is
' unallocated, an error will occur.
Var = UBound(Arr, 1)
If (Err.Number <> 0) Or (Var < 0) Then
    IsArrayEmpty = True
Else
    IsArrayEmpty = False
End If


End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Windows Callback procedures for EnumProps
' These addresses of these procedures are passed to the EnumProps API function.
' Windows will call the procedure passed to EnumProps one time for each property
' in the specified window's property list. These procedures MUST be declared
' exactly as shown. If you change the declarations, you'll crash Excel.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function ProcEnumPropForFind(ByVal HWnd As Long, ByVal Addr As Long, _
            ByVal Data As Long) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ProcEnumPropForFind
' This is the Windows callback function for determining if a property exits.  It
' is called by Windows for each property in the property list. We test the string
' value provided to this procedure against the value of PropertyToFind. If we get
' a match, the property exists and the PropertyFound value is set to True, and
' we terminate the enumeration.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Dim StringName As String
Dim Res As Long
Dim SLen As Long
Dim Pos As Integer


'''''''''''''''''''''''''''''''
' Set the PropertyFound variable
' to False.
''''''''''''''''''''''''''''''''
PropertyFound = False


'''''''''''''''''''''''''''''''
' Get the length of the string
' stored at the address Addr.
' This length does not include
' the trailing null character.
'''''''''''''''''''''''''''''''
SLen = LStrLen(Addr)


'''''''''''''''''''''''''''''''
' Allocate the StringName buffer.
' The +1 is to make room for the
' trailing null character.
'''''''''''''''''''''''''''''''
StringName = String$(SLen + 1, vbNullChar)


'''''''''''''''''''''''''''''''''''
' Copy the string from Addr to the
' StringName buffer variable.
'''''''''''''''''''''''''''''''''''
Res = LStrCpy(ByVal StringName, Addr)
If Res = 0 Then
    Debug.Print "An error occurred with LStrCpy.", Err.LastDllError
Else
    '''''''''''''''''''''''''''''''''''''''
    ' Trim off the trailing null character.
    '''''''''''''''''''''''''''''''''''''''
    Pos = InStr(1, StringName, vbNullChar)
    If Pos > 0 Then
        StringName = Left(StringName, Pos - 1)
    End If
    ''''''''''''''''''''''''''''''''''''''
    ' Compare PropertyName to StringName.
    ' If they match, set PropertyFound
    ' to True and terminate the enumeration
    ' by setting the function's return value
    ' to False.
    ''''''''''''''''''''''''''''''''''''''
    If StrComp(PropertyToFind, StringName, vbTextCompare) = 0 Then
        PropertyFound = True
        ProcEnumPropForFind = False
        Exit Function
    End If
End If
'''''''''''''''''''''''''''''
' Return True to continue the
' enumeration.
'''''''''''''''''''''''''''''
ProcEnumPropForFind = True


End Function




Private Function ProcEnumProp(ByVal HWnd As Long, ByVal Addr As Long, _
            ByVal Data As Long) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ProcEnumProp
' This is the callback function for EnumProps. Windows will call
' this function for each Property associated with the HWnd in the
' call to EnumProps.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim StringName As String
Dim Res As Long
Dim SLen As Long
Dim Pos As Integer


'''''''''''''''''''''''''''''''
' Get the length of the string
' stored at the address Addr.
' This length does not include
' the trailing null character.
'''''''''''''''''''''''''''''''
SLen = LStrLen(Addr)
'''''''''''''''''''''''''''''''
' Allocate the StringName buffer.
' The +1 is to make room for the
' trailing null character.
'''''''''''''''''''''''''''''''
StringName = String$(SLen + 1, vbNullChar)
'''''''''''''''''''''''''''''''''''
' Copy the string from Addr to the
' StringName buffer variable.
'''''''''''''''''''''''''''''''''''
Res = LStrCpy(ByVal StringName, Addr)
If Res = 0 Then
    Debug.Print "An error occurred with LStrCpy.", Err.LastDllError
Else
    '''''''''''''''''''''''''''''''''''''''
    ' Trim off the trailing null character.
    '''''''''''''''''''''''''''''''''''''''
    Pos = InStr(1, StringName, vbNullChar)
    If Pos > 0 Then
        StringName = Left(StringName, Pos - 1)
    End If
    Debug.Print CStr(Addr), StringName, CStr(Data)
End If
'''''''''''''''''''''''''''''
' Return True to continue the
' enumeration.
'''''''''''''''''''''''''''''
ProcEnumProp = True
End Function




Private Function ProcEnumPropForListAll(ByVal HWnd As Long, ByVal Addr As Long, _
            ByVal Data As Long) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ProcEnumPropForListAll
' This is the Windows callback procedure for EnumProps called by GetAllProperties. It
' stores each property name and associated value in a CPropType class instance and
' adds that to the module-level variable ListAllArray. ListAllArray should be Erased
' and ArrayNdx set to 0 prior to calling the EnumProps API function that calls this
' function.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Dim StringName As String
Dim Res As Long
Dim SLen As Long
Dim Pos As Integer
Dim PropType As CPropType
'''''''''''''''''''''''''''''''''
' Get the length of the string.
' This length does not include
' the trailing null character.
'''''''''''''''''''''''''''''''''
SLen = LStrLen(Addr)
'''''''''''''''''''''''''''''''''
' Allocate StringName to SLen+1
' vbNullChars. The +1 is for the
' trailing null character.
'''''''''''''''''''''''''''''''''
StringName = String$(SLen + 1, vbNullChar)
'''''''''''''''''''''''''''''''''''''''
' Copy the string from the address Addr
' to the StringName buffer variable.
'''''''''''''''''''''''''''''''''''''''
Res = LStrCpy(ByVal StringName, Addr)
''''''''''''''''''''''''''''''''''''''
' Trim to the vbNullChar if necessary.
''''''''''''''''''''''''''''''''''''''
Pos = InStr(1, StringName, vbNullChar)
If Pos > 0 Then
    StringName = Left(StringName, Pos - 1)
End If
'''''''''''''''''''''''''''''''''''''''''
' Create a new instance of CPropType,
' increment the array index and resize
' the array. Set the last element of
' the array to the new CPropType variable.
'''''''''''''''''''''''''''''''''''''''''
Set PropType = New CPropType
ArrayNdx = ArrayNdx + 1
ReDim Preserve ListAllArray(1 To ArrayNdx)
PropType.Name = StringName
PropType.Value = Data
Set ListAllArray(UBound(ListAllArray)) = PropType


'''''''''''''''''''''''''''''
' Return True to continue the
' enumeration.
'''''''''''''''''''''''''''''
ProcEnumPropForListAll = True
End Function

 

[crewaustin66]

I've had some luck with this Chip Pearson code.

Well, lots of good code to consume there! Thanks for sharing it.

How do you think that this will help me enter a password to unlock a project? I was told that they (M$) did not expose the add-in password or provide any methods for sending in a password to unlock the add-in.

Thanks Jeffrey,
-Crew

 

[Jeffrey Mahoney]

You're right, it will not unlock the VBA project. I read your request wrong.

 

[crewaustin66]

You're right, it will not unlock the VBA project. I read your request wrong.

No problem. I found Chip's page. That stuff is good for solving some problem sometime. Thanks for that.

Anyone else ... ideas?

Thanks,
-Crew

 

[Jaafar Tribak]

After much experimentation, I have managed to come up with a "solution" to this intriguing problem.

The following code seems to work even without bringing up the VBE window into existence and without needing the "Programmatic Access to Visual Basic Project" setting turned on plus the code can reside in the actual VB Project that is password protected.

Put the following code in a Standard Module, password-protect the workbook VB Project, save the workbook and close the entire excel application.

When you re-open the workbook, run the "Test" routine to unlock the VB Project .. You will be prompted to enter the password via a standard InputBox

Option Explicit

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As LongPtr, Source As LongPtr, ByVal Length As LongPtr)
    Private Declare PtrSafe Function VirtualProtect Lib "kernel32" (lpAddress As LongPtr, ByVal dwSize As LongPtr, ByVal flNewProtect As LongPtr, lpflOldProtect As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
    Private Declare PtrSafe Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As LongPtr, ByVal pTemplateName As LongPtr, ByVal hWndParent As LongPtr, ByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Function EndDialog Lib "user32" (ByVal hDlg As LongPtr, ByVal nResult As LongPtr) As Long
    Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
    Private Declare PtrSafe Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" (ByVal lpLibFileName As String, ByVal hFile As LongPtr, ByVal dwFlags As Long) As LongPtr
    Private Declare PtrSafe Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As LongPtr, ByVal lpFileName As String, ByVal nSize As Long) As Long
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private lDefFuncAddress As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Long, Source As Long, ByVal Length As Long)
    Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
    Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
    Private Declare Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As Long, ByVal pTemplateName As Long, ByVal hWndParent As Long, ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function EndDialog Lib "user32" (ByVal hDlg As Long, ByVal nResult As Long) As Long
    Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
    Private Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" (ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As Long
    Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private lDefFuncAddress As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private Const WM_INITDIALOG = &H110
Private Const LOAD_LIBRARY_AS_IMAGE_RESOURCE = &H20
Private Const PAGE_EXECUTE_READWRITE = &H40

Private Const PROJECT_PASSWORD = "JAAFAR" [COLOR=#008000][B]'<=== CASE SENSITIVE !! ..Change password as required[/B][/COLOR]

Private HookBytes(0 To 5) As Byte
Private OriginBytes(0 To 5) As Byte


Sub Test()

    Dim sPassWord As String
    
    sPassWord = InputBox("Enter Password", "Remove VBA Project Potection.")
    If StrPtr(sPassWord) = 0 Then Exit Sub
    If sPassWord <> PROJECT_PASSWORD Then MsgBox "Worng Password.", vbCritical: Exit Sub
    Call UnProtectVBProject(sPassWord)

End Sub

Private Sub UnProtectVBProject(ByVal Password As String)

    If GetProp(Application.hwnd, "HookSet") Then Exit Sub
    
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim hMod As LongPtr
        Dim hLib As LongPtr
        
        hMod = GetModuleHandle("VBE7INTL.DLL")
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Dim hMod As Long
        Dim hLib As Long
        
        hMod = GetModuleHandle("VBE6INTL.DLL")
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    Dim sBuffer As String
    Dim lRet As Long

    If hMod Then
        sBuffer = Space(256)
        lRet = GetModuleFileName(hMod, sBuffer, Len(sBuffer))
        If lRet Then
            hLib = LoadLibraryEx(Left(sBuffer, lRet), 0, LOAD_LIBRARY_AS_IMAGE_RESOURCE)
            Call DialogBoxParam(hLib, 4070, 0, AddressOf DialogBoxProc, 0)
            Call FreeLibrary(hLib)
        End If
    End If
    
End Sub


Private Sub SetHook(ByVal Hook As Boolean)

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Dim lNewFuncAddress As LongPtr
    Dim OriginProtect As LongPtr
    
    lNewFuncAddress = VBA.CLngPtr(AddressOf NewDialogBoxParamFunc)
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Dim lNewFuncAddress As Long
    Dim OriginProtect As Long
    
    lNewFuncAddress = VBA.CLng(AddressOf NewDialogBoxParamFunc)
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    Dim TmpBytes(0 To 5) As Byte

    If GetProp(Application.hwnd, "HookSet") = 0 Then
        If Hook Then
            lDefFuncAddress = GetProcAddress(GetModuleHandle("user32.dll"), "DialogBoxParamA")
            If VirtualProtect(ByVal lDefFuncAddress, 6, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then
                CopyMemory ByVal VarPtr(TmpBytes(0)), ByVal lDefFuncAddress, 6
                If TmpBytes(0) <> &H68 Then
                    CopyMemory ByVal VarPtr(OriginBytes(0)), ByVal lDefFuncAddress, 6
                    HookBytes(0) = &H68
                    CopyMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(lNewFuncAddress), 4
                    HookBytes(5) = &HC3
                    CopyMemory ByVal lDefFuncAddress, ByVal VarPtr(HookBytes(0)), 6
                End If
            End If
        Else
            If GetProp(Application.hwnd, "HookSet") = 0 Then
                SetProp Application.hwnd, "HookSet", 1
                CopyMemory ByVal lDefFuncAddress, ByVal VarPtr(OriginBytes(0)), 6
            End If
        End If
    End If
    
End Sub


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Function DialogBoxProc(ByVal hwndDlg As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Function DialogBoxProc(ByVal hwndDlg As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    If uMsg = WM_INITDIALOG Then
        EndDialog hwndDlg, 0
        Call SetHook(True)
        MsgBox "The VBA Project was unprotected successfully!"
    End If
    DialogBoxProc = 0
    
End Function

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Function NewDialogBoxParamFunc(ByVal hInstance As LongPtr, ByVal pTemplateName As LongPtr, ByVal hWndParent As LongPtr, ByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Function NewDialogBoxParamFunc(ByVal hInstance As Long, ByVal pTemplateName As Long, ByVal hWndParent As Long, ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    If pTemplateName = 4070 Then
        NewDialogBoxParamFunc = 1
        Call SetHook(False)
    End If
    
End Function

The code should be compatible with 32 and 64 bit but I've only tested it on my 64 bit excel/machine.

 

[crewaustin66]

This is great stuff Jaafar. I'm confused, though, on one point. I need to be able to tell it to ask for the password on a specific .xla that is already loaded into the projects. How can I specify that? My goal is to be able to give your code either a project name or an add-in .xla filename that is loaded and have it unlock the add-in with a known password.

Thanks for the help!
-Crew

 

[Jaafar Tribak]

Just add the code to a standard module in the unlocked addin and run the test routine .. You will be prompted to enter a password which is "JAAFAR"(You can change this password in the code declaration section to whatever you like).

You don't need the name of the specific add-in locked project .

 

[crewaustin66]

Yes, I understand. You're code is running fine and the password request is coming up as designed. Here's what I am trying to do.
1. Pick two .xla files using custom VBA code in an .xlam ribbon.
2. Load .xla 1 (locked). I need to unlock it by filename.xla and rename the project to "compf1" (from the .xlam)
3. Once done, I can have the .xlam code run through the project (by name) and export the source to a text.file.

I am missing one little step on #2 . From the .xlam where your code resides, how do I tell it to unload project compf1.xla? I can't rename it until it is unlocked. If we can figure that out I'm home free!

Thanks,
Crew

 

[Jaafar Tribak]

Once done, I can have the .xlam code run through the project (by name) and export the source to a text.file.

Do you want to export the source code of which module in the .xla project ? and is there a reason why you need to rename the project to "compf1" before performing the export ?