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

C

crewaustin66

Board Regular
Joined
Jun 11, 2014
Messages
82
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
 
Sort by date Sort by votes
The .xlam installs the temporary add-in. There is code in the .xlam that runs through ALL of the modules and form code found in the .xla. Right now, this only work if I debug it, let the .xla get installed (which works) and manually take the password off and then let it run. As for why I need to change the project name, the .xla's are all version of a project called ZOptionGLSU. When I load an older version of the .xla the project name is also ZOptionGLSU. Therefore I cannot look for the project by name. I must first find the add-in by filename and then change the project name so that I can use code as follows:

' Write out the source code
LongStr = vbproj.Collection(projectName).VBComponents("Main").CodeModule.Lines(500, 500)

I hope this clarifies things a bit.

Thanks again,
-Crew
 
Upvote 0

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
How about using the Addin name instead of the Project name :

Code: 
[COLOR=#333333][FONT=Verdana]LongStr =[/FONT][/COLOR]Workbooks("[COLOR=#0000ff][B]Your_ADDIN_Name.xla[/B][/COLOR]").VBProject.VBComponents("Main").CodeModule.Lines(500, 500)
 
Last edited:
Upvote 0
I may be able to do that, not sure. It does work given a unique project name. However, the real issue is that one cannot get any code information out of a locked project. It must be unlocked first. This is why I need my .xlam to "reach into project ABC" to export the source to a flat file.

Thanks for any help,
-Crew
 
Last edited:
Upvote 0
Well ... I placed the code in the project that I want to unprotect. I call your unlock sub from within the project now. Although the code declares that the project is unlocked, it apparently is not. Further, if I call it twice (once for project A and once for project B from my compare.xla toolbar) the code takes Excel down. I'll keep playing with it but, in theory, it should work. Thanks for the help!
 
Upvote 0
For now, this works for my purposes. I would rather use yours but I'm having the challenges as stated in the last message.

Code: 
Sub UnlockProject()    Application.SendKeys "%{F11}^r{HOME}{TAB}%TEpassword{ENTER}{ENTER}%{F4}", True
End Sub
 
Last edited:
Upvote 0
I am writing some new code also API-based but using a different approach which I'll post here later when I am done .. so stay tuned :)

This new code assumes the following for it to work :

1- You know the locked VBProject existing password (Obviously)
2- You know the name of the workbook or Addin whose VBProject you want to unlock and rename.
3- have the "Trust Access to the VBA Project Object Model" setting turned on.
 
Last edited:
Upvote 0
Sorry for the late response.

The following code should enable you to unlock a workbook/addin Project and rename the project all programmatically.

Place the code in a new Standard Module and run the 'Test' routine :

Code: 
Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then

    Private Type TVITEM
        mask           As Long
        hItem          As LongPtr
        state          As Long
        stateMask      As Long
        pszText        As String
        cchTextMax     As Long
        iImage         As Long
        iSelectedImage As Long
        cChildren      As Long
        lParam         As LongPtr
    End Type
    
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hMod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
    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 Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function SendMessageByRef Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As String) As LongPtr
    Private hHook As LongPtr, hwndVBE As LongPtr, hwndLV As LongPtr, hNode As LongPtr, hChildNode As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 

    Private Type TVITEM
        mask           As Long
        hItem          As Long
        state          As Long
        stateMask      As Long
        pszText        As String
        cchTextMax     As Long
        iImage         As Long
        iSelectedImage As Long
        cChildren      As Long
        lParam         As Long
    End Type
    
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem 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 Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch 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 FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function SendMessageByRef Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
    Private hHook As Long, hwndVBE As Long, hwndLV As Long, hNode As Long, hChildNode As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private Const TV_FIRST = &H1100
Private Const TVM_GETNEXTITEM = (TV_FIRST + 10)
Private Const TVM_SELECTITEM = (TV_FIRST + 11)
Private Const TVM_GETITEM = TV_FIRST + 12
Private Const TVM_EXPAND = TV_FIRST + 2
Private Const TVE_EXPAND = &H2
Private Const TVGN_CARET = &H9
Private Const TVGN_ROOT = &H0
Private Const TVGN_NEXT = &H1
Private Const TVIF_TEXT = &H1
Private Const TVGN_CHILD = &H4
Private Const BM_CLICK = &HF5
Private Const WM_SETTEXT = &HC
Private Const MAX_ITEM = 256
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5

Private bFlag As Boolean
Private sVBAProjectPassword   As String


Sub Test()

    Dim sWorkBookName As String
    Dim sVBProjectExistingPassword As String
    Dim sNewVBProjectName As String
    
    sWorkBookName = "MyAddin.xla"           [B][COLOR=#008000]' <== Change the locked Workbook/Addin name as required.[/COLOR][/B]
    sVBProjectExistingPassword = "jaafar"   [B][COLOR=#008000]' <== Change the locked VBProject password as required.[/COLOR][/B]
    sNewVBProjectName = "projectABC"        [B][COLOR=#008000]' <== Change this new VBProject name as required.[/COLOR][/B]
        
    If UnlockAndRenameVBProject(sWorkBookName, sVBProjectExistingPassword, sNewVBProjectName) Then
    
        MsgBox "sucess"
        
        [B][COLOR=#008000]' If succes,continue with your code here....[/COLOR][/B]
        [B][COLOR=#008000]' ******************************************[/COLOR][/B]
        
       [COLOR=#008000] ' Dim LongStr As String[/COLOR]
        [COLOR=#008000]' LongStr = Application.VBE.VBProjects("projectABC").VBComponents("Main").CodeModule.Lines(500, 500)[/COLOR]
    End If

End Sub


Private Function UnlockAndRenameVBProject(ByVal WorkbookName As String, ByVal VBProjectPassword As String, ByVal NewVBProjectName As String) As Boolean

    Dim sPrevVBProjectName As String, sErrorFeedBack As String
    Dim tVI As TVITEM, oWb As Object

    On Error GoTo errHandler

    bFlag = False
    sVBAProjectPassword = VBProjectPassword
    Set oWb = Workbooks(WorkbookName)
 
    hwndVBE = FindWindow("wndclass_desked_gsk", vbNullString)
    
    If hwndVBE = 0 Then
        Application.VBE.MainWindow.Visible = True
        Application.VBE.MainWindow.Visible = False
    End If
    
    If hwndVBE Then
        hwndLV = FindWindowEx(hwndVBE, 0, "PROJECT", vbNullString)
        hwndLV = FindWindowEx(hwndLV, 0, "SysTreeView32", vbNullString)
        hNode = SendMessage(hwndLV, TVM_GETNEXTITEM, TVGN_ROOT, 0)

        Do While hNode <> 0
            tVI.hItem = hNode
            tVI.mask = TVIF_TEXT
            tVI.cchTextMax = MAX_ITEM
            tVI.pszText = String(MAX_ITEM, 0)
            Call SendMessageByRef(hwndLV, TVM_GETITEM, 0, tVI)
            If InStr(1, tVI.pszText, WorkbookName, vbTextCompare) > 0 Then
                Call SetHook
                hChildNode = SendMessage(hwndLV, TVM_SELECTITEM, TVGN_CARET, ByVal hNode)
                hChildNode = SendMessage(hwndLV, TVM_GETNEXTITEM, TVGN_CHILD, ByVal hNode)
                Call SendMessage(hwndLV, TVM_EXPAND, TVE_EXPAND, ByVal hChildNode)
                hChildNode = SendMessage(hwndLV, TVM_GETNEXTITEM, TVGN_CHILD, hChildNode)
                Call SendMessage(hwndLV, TVM_GETNEXTITEM, TVGN_NEXT, hChildNode)
                Call SendMessage(hwndLV, TVM_SELECTITEM, TVGN_CARET, ByVal hChildNode)
                Call SendMessage(hwndLV, TVM_GETNEXTITEM, TVGN_NEXT, ByVal hChildNode)
                Call SendMessage(hwndLV, TVM_EXPAND, TVE_EXPAND, ByVal hChildNode)
                sPrevVBProjectName = Application.VBE.ActiveVBProject.Name
                DoEvents
                Application.VBE.ActiveVBProject.Name = NewVBProjectName
            End If
        hNode = SendMessage(hwndLV, TVM_GETNEXTITEM, TVGN_NEXT, hNode)
        DoEvents
        Loop
    End If

errHandler:
    
      Call RemoveHook
      
      Select Case Err
        Case 9, -2147352565
            sErrorFeedBack = "The Workbook or Addin whose name is :" & vbLf & "'" & WorkbookName & "'" & " is not open."
        Case 50132
            bFlag = True
            sErrorFeedBack = "The VBProject : '" & sPrevVBProjectName & "' was successfully unlocked but " & vbLf
            sErrorFeedBack = sErrorFeedBack & "failed to be renamed due to the existence of one or more " & vbLf
            sErrorFeedBack = sErrorFeedBack & "invalid characters in the new VBProject name that was provided !" & vbLf & vbLf
            sErrorFeedBack = sErrorFeedBack & "Remove the invalid character(s) and try again."
        Case 50289
            sErrorFeedBack = "Incorrect VBAProject Password."
        Case 1004
            sErrorFeedBack = "Programmatic Access To Visual Basic Is Not Trusted." & vbLf & vbLf
            sErrorFeedBack = sErrorFeedBack & "Click to select the Trust access to the VBA project object model check box under 'Macros Security'."
        Case 0
            UnlockAndRenameVBProject = True
      End Select
      
        If sErrorFeedBack <> "" Then
            MsgBox sErrorFeedBack, IIf(Err = 50132, vbExclamation, vbCritical), "Error."
        End If

End Function

Private Sub SetHook()
    hHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId)
    SetProp Application.hwnd, "hhook", hHook
End Sub

Private Sub RemoveHook()
    UnhookWindowsHookEx GetProp(Application.hwnd, "hhook")
End Sub

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Function HookProc(ByVal idHook 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 HookProc(ByVal idHook 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
    Dim lRet As Long
    Dim sBuffer As String
    
    If idHook = HCBT_ACTIVATE Then
        sBuffer = Space(256)
        lRet = GetClassName(wParam, sBuffer, 256)
        If Left(sBuffer, lRet) = "#32770" Then
            Call SendMessageByString(GetDlgItem(wParam, &H155E), WM_SETTEXT, 0, ByVal sVBAProjectPassword)
            Call SendMessage(GetDlgItem(wParam, 1), BM_CLICK, 0, ByVal 0)
            If bFlag Then
                Call SendMessage(GetDlgItem(wParam, 2), BM_CLICK, 0, ByVal 0)
            End If
            bFlag = True
        End If
    End If
    HookProc = CallNextHookEx(hHook, idHook, ByVal wParam, ByVal lParam)
End Function

Hope this works for you.
 
Last edited:
Upvote 0
I have just tested the above code on a 32 bit system and found a small logic error which I have now corrected .. so ignore the code in post#19 and use the following one :

Code in a new Standard Module and run the 'Test' routine :

Code: 
Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then

    Private Type TVITEM
        mask           As Long
        hItem          As LongPtr
        state          As Long
        stateMask      As Long
        pszText        As String
        cchTextMax     As Long
        iImage         As Long
        iSelectedImage As Long
        cChildren      As Long
        lParam         As LongPtr
    End Type
    
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hMod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
    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 Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function SendMessageByRef Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As String) As LongPtr
    Private hHook As LongPtr, hwndVBE As LongPtr, hwndLV As LongPtr, hNode As LongPtr, hChildNode As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 

    Private Type TVITEM
        mask           As Long
        hItem          As Long
        state          As Long
        stateMask      As Long
        pszText        As String
        cchTextMax     As Long
        iImage         As Long
        iSelectedImage As Long
        cChildren      As Long
        lParam         As Long
    End Type
    
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem 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 Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch 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 FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function SendMessageByRef Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
    Private hHook As Long, hwndVBE As Long, hwndLV As Long, hNode As Long, hChildNode As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private Const TV_FIRST = &H1100
Private Const TVM_GETNEXTITEM = (TV_FIRST + 10)
Private Const TVM_SELECTITEM = (TV_FIRST + 11)
Private Const TVM_GETITEM = TV_FIRST + 12
Private Const TVM_EXPAND = TV_FIRST + 2
Private Const TVE_EXPAND = &H2
Private Const TVGN_CARET = &H9
Private Const TVGN_ROOT = &H0
Private Const TVGN_NEXT = &H1
Private Const TVIF_TEXT = &H1
Private Const TVGN_CHILD = &H4
Private Const BM_CLICK = &HF5
Private Const WM_SETTEXT = &HC
Private Const MAX_ITEM = 256
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5

Private bFlag As Boolean
Private sVBAProjectPassword   As String


Sub Test()

    Dim sWorkBookName As String
    Dim sVBProjectExistingPassword As String
    Dim sNewVBProjectName As String
    
    sWorkBookName = "MyAddin.xla"           [B][COLOR=#008000]' <== Change the locked Workbook/Addin name as required.[/COLOR][/B]
    sVBProjectExistingPassword = "jaafar"   [B][COLOR=#008000]' <== Change the locked VBProject password as required.[/COLOR][/B]
    sNewVBProjectName = "projectABC"        [B][COLOR=#008000]' <== Change this new VBProject name as required.[/COLOR][/B]
        
    If UnlockAndRenameVBProject(sWorkBookName, sVBProjectExistingPassword, sNewVBProjectName) Then
    
        MsgBox "sucess"
        
        [COLOR=#008000]' If succes,continue with your code here....[/COLOR]
        [COLOR=#008000]' ******************************************[/COLOR]
        
        [COLOR=#008000]' Dim LongStr As String[/COLOR]
       [COLOR=#008000] ' LongStr = Application.VBE.VBProjects("projectABC").VBComponents("Main").CodeModule.Lines(500, 500)[/COLOR]
    End If
End Sub


Private Function UnlockAndRenameVBProject(ByVal WorkbookName As String, ByVal VBProjectPassword As String, ByVal NewVBProjectName As String) As Boolean

    Dim sPrevVBProjectName As String, sErrorFeedBack As String
    Dim tVI As TVITEM, oWb As Object

    On Error GoTo errHandler

    bFlag = False
    sVBAProjectPassword = VBProjectPassword
    Set oWb = Workbooks(WorkbookName)
 
    hwndVBE = FindWindow("wndclass_desked_gsk", vbNullString)
    
    If hwndVBE = 0 Then
        Application.VBE.MainWindow.Visible = True
        Application.VBE.MainWindow.Visible = False
        hwndVBE = FindWindow("wndclass_desked_gsk", vbNullString)
    End If
    
    If hwndVBE Then
        hwndLV = FindWindowEx(hwndVBE, 0, "PROJECT", vbNullString)
        hwndLV = FindWindowEx(hwndLV, 0, "SysTreeView32", vbNullString)
        hNode = SendMessage(hwndLV, TVM_GETNEXTITEM, TVGN_ROOT, 0)

        Do While hNode <> 0
            tVI.hItem = hNode
            tVI.mask = TVIF_TEXT
            tVI.cchTextMax = MAX_ITEM
            tVI.pszText = String(MAX_ITEM, 0)
            Call SendMessageByRef(hwndLV, TVM_GETITEM, 0, tVI)
            If InStr(1, tVI.pszText, WorkbookName, vbTextCompare) > 0 Then
                Call SetHook
                hChildNode = SendMessage(hwndLV, TVM_SELECTITEM, TVGN_CARET, ByVal hNode)
                hChildNode = SendMessage(hwndLV, TVM_GETNEXTITEM, TVGN_CHILD, ByVal hNode)
                Call SendMessage(hwndLV, TVM_EXPAND, TVE_EXPAND, ByVal hChildNode)
                hChildNode = SendMessage(hwndLV, TVM_GETNEXTITEM, TVGN_CHILD, hChildNode)
                Call SendMessage(hwndLV, TVM_GETNEXTITEM, TVGN_NEXT, hChildNode)
                Call SendMessage(hwndLV, TVM_SELECTITEM, TVGN_CARET, ByVal hChildNode)
                Call SendMessage(hwndLV, TVM_GETNEXTITEM, TVGN_NEXT, ByVal hChildNode)
                Call SendMessage(hwndLV, TVM_EXPAND, TVE_EXPAND, ByVal hChildNode)
                sPrevVBProjectName = Application.VBE.ActiveVBProject.Name
                DoEvents
                Application.VBE.ActiveVBProject.Name = NewVBProjectName
            End If
        hNode = SendMessage(hwndLV, TVM_GETNEXTITEM, TVGN_NEXT, hNode)
        DoEvents
        Loop
    End If

errHandler:
    
    Call RemoveHook
    
    Select Case Err
        Case 9, -2147352565
            sErrorFeedBack = "The Workbook or Addin whose name is :" & vbLf & "'" & WorkbookName & "'" & " is not open."
        Case 50132
            bFlag = True
            sErrorFeedBack = "The VBProject : '" & sPrevVBProjectName & "' was successfully unlocked but " & vbLf
            sErrorFeedBack = sErrorFeedBack & "failed to be renamed due to the existence of one or more " & vbLf
            sErrorFeedBack = sErrorFeedBack & "invalid characters in the new VBProject name that was provided !" & vbLf & vbLf
            sErrorFeedBack = sErrorFeedBack & "Remove the invalid character(s) and try again."
        Case 50289
            sErrorFeedBack = "Incorrect VBAProject Password."
        Case 1004
            sErrorFeedBack = "Programmatic Access To Visual Basic Is Not Trusted." & vbLf & vbLf
            sErrorFeedBack = sErrorFeedBack & "Click to select the Trust access to the VBA project object model check box under 'Macros Security'."
        Case 0
            UnlockAndRenameVBProject = True
    End Select
    
    If sErrorFeedBack <> "" Then
        MsgBox sErrorFeedBack, IIf(Err = 50132, vbExclamation, vbCritical), "Error."
    End If

End Function

Private Sub SetHook()
    hHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId)
    SetProp Application.hwnd, "hhook", hHook
End Sub

Private Sub RemoveHook()
    UnhookWindowsHookEx GetProp(Application.hwnd, "hhook")
End Sub

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function HookProc(ByVal idHook 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 HookProc(ByVal idHook 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
    Dim lRet As Long
    Dim sBuffer As String
    
    If idHook = HCBT_ACTIVATE Then
        sBuffer = Space(256)
        lRet = GetClassName(wParam, sBuffer, 256)
        If Left(sBuffer, lRet) = "#32770" Then
            Call SendMessageByString(GetDlgItem(wParam, &H155E), WM_SETTEXT, 0, ByVal sVBAProjectPassword)
            Call SendMessage(GetDlgItem(wParam, 1), BM_CLICK, 0, ByVal 0)
            If bFlag Then
                Call SendMessage(GetDlgItem(wParam, 2), BM_CLICK, 0, ByVal 0)
            End If
            bFlag = True
        End If
    End If
    HookProc = CallNextHookEx(hHook, idHook, ByVal wParam, ByVal lParam)
End Function
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
How to automatically change a Module code in multiple protected Visual Basic projects
Replies
1
Views
1K
RoryA
RoryA
H
  • Question Question
Prevent VBE from idling when user action is required (Win32 APIs)
2
Replies
12
Views
3K
Jaafar Tribak
Jaafar Tribak
S
  • Question Question
Run a macro in a workbook using a separate instance of Excel
Replies
0
Views
1K
StillUnderstanding
S
M
  • Question Question
How can I fix my script so that it sends out the copy and pasted data from this worksheet to an email?
Replies
0
Views
596
mrindira
M
reasem
  • Question Question
How to use URLDownloadToFile to download after login page (Username and Password)
Replies
0
Views
3K
reasem
reasem

Forum statistics

Threads
1,223,909
Messages
6,175,313
Members
452,634
Latest member
cpostell

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top