Снять защиту с VBProject с кода VB

Question

Снять защиту с VBProject с кода VB

Как я могу снять защиту моего проекта VB от макроса VB? я нашел этот код:

    Sub UnprotectVBProject(ByRef WB As Workbook, ByVal Password As String)
  Dim VBProj As Object
  Set VBProj = WB.VBProject
  Application.ScreenUpdating = False
  'Ne peut procéder si le projet est non-protégé.
  If VBProj.Protection <> 1 Then Exit Sub
  Set Application.VBE.ActiveVBProject = VBProj
  'Utilisation de "SendKeys" Pour envoyer le mot de passe.

  SendKeys Password & "~"
  SendKeys "~"
  'MsgBox "Après Mot de passe"
  Application.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
  Application.Wait (Now + TimeValue("0:00:1"))

End Sub

Но это решение не работает для Excel 2007. Оно отображает окно аутентификации и пароль для печати в моей IDE.

Затем моя цель - снять защиту с моего VB project без отображения этого окна.

Спасибо за любую помощь.

31

excel vba excel-vba excel-2007

Источник

user1591681 23 апр '13 в 16:24

4 ответа

Решение

Я знаю, что вы заблокировали это для новых ответов, но у меня было несколько проблем с приведенным выше кодом, главным образом из-за того, что я работаю в 64-битной версии Office (VBA7). Однако я также сделал так, чтобы код работал в текущем экземпляре Excel, и добавил немного больше проверки ошибок и отформатировал его для вставки в отдельный модуль только с методом UnlockProject подвергаются.

Для полного раскрытия я действительно начал с кода в этом посте, хотя это вариант на тему.

Код также показывает константы условной компиляции, поэтому он должен быть совместим как с 32-разрядными, так и с 64-разрядными версиями Excel одновременно. Я использовал эту страницу, чтобы помочь мне понять это.

В любом случае вот код. Надеюсь, кто-то найдет это полезным:

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hwndParent As LongPtr, ByVal hwndChildAfter As LongPtr, ByVal lpszClass As String, ByVal lpszWindow As String) As LongPtr
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr ' nIDDlgItem = int?
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare PtrSafe Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function LockWindowUpdate Lib "user32" (ByVal hWndLock As LongPtr) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal uIDEvent As LongPtr) As Long
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hwndParent As Long, ByVal hwndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
    Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long ' nIDDlgItem = int?
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hWnd As Long) As Long
    Private Declare Function LockWindowUpdate Lib "user32" (ByVal hWndLock As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal uIDEvent As Long) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Private Const WM_CLOSE As Long = &H10
Private Const WM_GETTEXT As Long = &HD
Private Const EM_REPLACESEL As Long = &HC2
Private Const EM_SETSEL As Long = &HB1
Private Const BM_CLICK As Long = &HF5&
Private Const TCM_SETCURFOCUS As Long = &H1330&
Private Const IDPassword As Long = &H155E&
Private Const IDOK As Long = &H1&

Private Const TimeoutSecond As Long = 2

Private g_ProjectName    As String
Private g_Password       As String
Private g_Result         As Long
#If VBA7 Then
    Private g_hwndVBE        As LongPtr
    Private g_hwndPassword   As LongPtr
#Else
    Private g_hwndVBE        As Long
    Private g_hwndPassword   As Long
#End If

Sub Test_UnlockProject()
    Select Case UnlockProject(ActiveWorkbook.VBProject, "Test")
        Case 0: MsgBox "The project was unlocked"
        Case 2: MsgBox "The active project was already unlocked"
        Case Else: MsgBox "Error or timeout"
    End Select
End Sub

Public Function UnlockProject(ByVal Project As Object, ByVal Password As String) As Long

#If VBA7 Then
    Dim lRet As LongPtr
#Else
    Dim lRet As Long
#End If
Dim timeout As Date

    On Error GoTo ErrorHandler
    UnlockProject = 1

    ' If project already unlocked then no need to do anything fancy
    ' Return status 2 to indicate already unlocked
    If Project.Protection <> vbext_pp_locked Then
        UnlockProject = 2
        Exit Function
    End If

    ' Set global varaibles for the project name, the password and the result of the callback
    g_ProjectName = Project.Name
    g_Password = Password
    g_Result = 0

    ' Freeze windows updates so user doesn't see the magic happening :)
    ' This is dangerous if the program crashes as will 'lock' user out of Windows
    ' LockWindowUpdate GetDesktopWindow()

    ' Switch to the VBE
    ' and set the VBE window handle as a global variable
    Application.VBE.MainWindow.Visible = True
    g_hwndVBE = Application.VBE.MainWindow.hWnd

    ' Run 'UnlockTimerProc' as a callback
    lRet = SetTimer(0, 0, 100, AddressOf UnlockTimerProc)
    If lRet = 0 Then
        Debug.Print "error setting timer"
        GoTo ErrorHandler
    End If

    ' Switch to the project we want to unlock
    Set Application.VBE.ActiveVBProject = Project
    If Not Application.VBE.ActiveVBProject Is Project Then GoTo ErrorHandler

    ' Launch the menu item Tools -> VBA Project Properties
    ' This will trigger the password dialog
    ' which will then get picked up by the callback
    Application.VBE.CommandBars.FindControl(ID:=2578).Execute

    ' Loop until callback procedure 'UnlockTimerProc' has run
    ' determine run by watching the state of the global variable 'g_result'
    ' ... or backstop of 2 seconds max
    timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
    Do While g_Result = 0 And Now() < timeout
        DoEvents
    Loop
    If g_Result Then UnlockProject = 0

ErrorHandler:
    ' Switch back to the Excel application
    AppActivate Application.Caption

    ' Unfreeze window updates
    LockWindowUpdate 0

End Function

#If VBA7 Then
    Private Function UnlockTimerProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long) As Long
#Else
    Private Function UnlockTimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) As Long
#End If

#If VBA7 Then
    Dim hWndPassword As LongPtr
    Dim hWndOK As LongPtr
    Dim hWndTmp As LongPtr
    Dim lRet As LongPtr
#Else
    Dim hWndPassword As Long
    Dim hWndOK As Long
    Dim hWndTmp As Long
    Dim lRet As Long
#End If
Dim lRet2 As Long
Dim sCaption As String
Dim timeout As Date
Dim timeout2 As Date
Dim pwd As String

    ' Protect ourselves against failure :)
    On Error GoTo ErrorHandler

    ' Kill timer used to initiate this callback
    KillTimer 0, idEvent

    ' Determine the Title for the password dialog
    Select Case Application.LanguageSettings.LanguageID(msoLanguageIDUI)
        ' For the japanese version
        Case 1041
            sCaption = ChrW(&H30D7) & ChrW(&H30ED) & ChrW(&H30B8) & _
                        ChrW(&H30A7) & ChrW(&H30AF) & ChrW(&H30C8) & _
                        ChrW(&H20) & ChrW(&H30D7) & ChrW(&H30ED) & _
                        ChrW(&H30D1) & ChrW(&H30C6) & ChrW(&H30A3)
        Case Else
            sCaption = " Password"
    End Select
    sCaption = g_ProjectName & sCaption

    ' Set a max timeout of 2 seconds to guard against endless loop failure
    timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
    Do While Now() < timeout

        hWndPassword = 0
        hWndOK = 0
        hWndTmp = 0

        ' Loop until find a window with the correct title that is a child of the
        ' VBE handle for the project to unlock we found in 'UnlockProject'
        Do
            hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
            If hWndTmp = 0 Then Exit Do
        Loop Until GetParent(hWndTmp) = g_hwndVBE

        ' If we don't find it then could be that the calling routine hasn't yet triggered
        ' the appearance of the dialog box
        ' Skip to the end of the loop, wait 0.1 secs and try again
        If hWndTmp = 0 Then GoTo Continue

        ' Found the dialog box, make sure it has focus
        Debug.Print "found window"
        lRet2 = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)

        ' Get the handle for the password input
        hWndPassword = GetDlgItem(hWndTmp, IDPassword)
        Debug.Print "hwndpassword: " & hWndPassword

        ' Get the handle for the OK button
        hWndOK = GetDlgItem(hWndTmp, IDOK)
        Debug.Print "hwndOK: " & hWndOK

        ' If either handle is zero then we have an issue
        ' Skip to the end of the loop, wait 0.1 secs and try again
        If (hWndTmp And hWndOK) = 0 Then GoTo Continue

        ' Enter the password ionto the password box
        lRet = SetFocusAPI(hWndPassword)
        lRet2 = SendMessage(hWndPassword, EM_SETSEL, 0, ByVal -1&)
        lRet2 = SendMessage(hWndPassword, EM_REPLACESEL, 0, ByVal g_Password)

        ' As a check, get the text back out of the pasword box and verify it's the same
        pwd = String(260, Chr(0))
        lRet2 = SendMessage(hWndPassword, WM_GETTEXT, Len(pwd), ByVal pwd)
        pwd = Left(pwd, InStr(1, pwd, Chr(0), 0) - 1)
        ' If not the same then we have an issue
        ' Skip to the end of the loop, wait 0.1 secs and try again
        If pwd <> g_Password Then GoTo Continue

        ' Now we need to close the Project Properties window we opened to trigger
        ' the password input in the first place
        ' Like the current routine, do it as a callback
        lRet = SetTimer(0, 0, 100, AddressOf ClosePropertiesWindow)

        ' Click the OK button
        lRet = SetFocusAPI(hWndOK)
        lRet2 = SendMessage(hWndOK, BM_CLICK, 0, ByVal 0&)

        ' Set the gloabal variable to success to flag back up to the initiating routine
        ' that this worked
        g_Result = 1
        Exit Do

        ' If we get here then something didn't work above
        ' Wait 0.1 secs and try again
        ' Master loop is capped with a longstop of 2 secs to terminate endless loops
Continue:
        DoEvents
        Sleep 100
    Loop
    Exit Function

    ' If we get here something went wrong so close the password dialog box (if we have a handle)
    ' and unfreeze window updates (if we set that in the first place)
ErrorHandler:
    Debug.Print Err.Number
    If hWndPassword <> 0 Then SendMessage hWndPassword, WM_CLOSE, 0, ByVal 0&
    LockWindowUpdate 0

End Function

#If VBA7 Then
    Function ClosePropertiesWindow(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long) As Long
#Else
    Function ClosePropertiesWindow(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) As Long
#End If

#If VBA7 Then
    Dim hWndTmp As LongPtr
    Dim hWndOK As LongPtr
    Dim lRet As LongPtr
#Else
    Dim hWndTmp As Long
    Dim hWndOK As Long
    Dim lRet As Long
#End If
Dim lRet2 As Long
Dim timeout As Date
Dim sCaption As String

    ' Protect ourselves against failure :)
    On Error GoTo ErrorHandler

    ' Kill timer used to initiate this callback
    KillTimer 0, idEvent

    ' Determine the Title for the project properties dialog
    sCaption = g_ProjectName & " - Project Properties"
    Debug.Print sCaption

    ' Set a max timeout of 2 seconds to guard against endless loop failure
    timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
    Do While Now() < timeout

        hWndTmp = 0

        ' Loop until find a window with the correct title that is a child of the
        ' VBE handle for the project to unlock we found in 'UnlockProject'
        Do
            hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
            If hWndTmp = 0 Then Exit Do
        Loop Until GetParent(hWndTmp) = g_hwndVBE

        ' If we don't find it then could be that the calling routine hasn't yet triggered
        ' the appearance of the dialog box
        ' Skip to the end of the loop, wait 0.1 secs and try again
        If hWndTmp = 0 Then GoTo Continue

        ' Found the dialog box, make sure it has focus
        Debug.Print "found properties window"
        lRet2 = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)

        ' Get the handle for the OK button
        hWndOK = GetDlgItem(hWndTmp, IDOK)
        Debug.Print "hwndOK: " & hWndOK

        ' If either handle is zero then we have an issue
        ' Skip to the end of the loop, wait 0.1 secs and try again
        If (hWndTmp And hWndOK) = 0 Then GoTo Continue

        ' Click the OK button
        lRet = SetFocusAPI(hWndOK)
        lRet2 = SendMessage(hWndOK, BM_CLICK, 0, ByVal 0&)

        ' Set the gloabal variable to success to flag back up to the initiating routine
        ' that this worked
        g_Result = 1
        Exit Do

        ' If we get here then something didn't work above
        ' Wait 0.1 secs and try again
        ' Master loop is capped with a longstop of 2 secs to terminate endless loops
Continue:
        DoEvents
        Sleep 100
    Loop
    Exit Function

    ' If we get here something went wrong so unfreeze window updates (if we set that in the first place)
ErrorHandler:
    Debug.Print Err.Number
    LockWindowUpdate 0

End Function

14

Источник

user1484738 09 май '17 в 15:39

Предложение по модификации фантастического решения Джеймса Макади:

вFunction UnlockTimerProc, замените кодpwd = Left(pwd, ...сpwd = VBA.Left(pwd, ..., иначе с некоторыми книгами не получается, в чем мне было трудно разобраться. Спасибо. Привет.

0

Источник

UnoStackOverflow 16 апр '23 в 16:13

Ответ @James Macadie (выше) - лучший, который я нашел (у меня 32-разрядная версия Excel 365/2019)

Примечание . Я обнаружил, что у вас должен быть Application.ScreenUpdating = Trueчтобы вызвать метод Джеймса через другую подпрограмму или функцию. В противном случае вы можете получить Invalid procedure call or argumentошибка (при работе вне режима отладки).

Это решение кажется лучше, чем оба следующих:

http://www.siddharthrout.com/index.php/2019/01/20/unprotect-vbproject-from-vb-code/ . создает отдельный экземпляр приложения Excel для запуска процесса разблокировки, который не работал в моем случае использования
https://www.mrexcel.com/board/threads/lock-unlock-vbaprojects-programmatically-without-sendkeys.1136415/ . нестабилен и выйдет из строя при последовательном запуске для нескольких книг, я думаю, из-за отсутствия циклов таймера/ожидания, реализованных в решении Джеймса - я не полностью отладил проблему

0

Источник

user6014628 11 дек '20 в 05:10

Другие вопросы по тегам excel vba excel-vba excel-2007

user1140579 23 апр '13 в 18:27 2013-04-23 18:27 · Accepted Answer · 2013-04-23 18:27

РЕДАКТИРОВАТЬ:

Преобразовал это в сообщение блога для VBA и VB.Net.

Я никогда не был за Sendkeys, Они надежны в некоторых случаях, но не всегда. У меня есть мягкий уголок для API, хотя.

То, чего вы хотите, может быть достигнуто, однако вы должны убедиться, что рабочая книга, для которой вы хотите отменить защиту VBA, должна быть открыта в отдельном экземпляре Excel.

Вот пример

Допустим, у нас есть рабочая книга, проект VBA которой выглядит в настоящее время так.

ЛОГИКА:

Найдите дескриптор окна "Пароль VBAProject", используя FindWindow
Как только это будет найдено, найдите дескриптор окна редактирования в этом окне, используя FindWindowEx
Как только дескриптор окна редактирования найден, просто используйте SendMessage написать ему.
Найдите ручку Buttons в этом окне, используя FindWindowEx
Однажды ручка OK кнопка найдена, просто используйте SendMessage щелкнуть по нему.

РЕКОМЕНДАЦИЯ:

Для API это лучшая ссылка, которую я могу рекомендовать.
Если вы хотите стать хорошим в API, как FindWindow, FindWindowEx а также SendMessage затем получите инструмент, который дает вам графическое представление о системных процессах, потоках, окнах и оконных сообщениях. Например: uuSpy или Spy++.

Вот что Spy ++ покажет вам для окна "Пароль VBAProject"

ТЕСТИРОВАНИЕ:

Откройте новый экземпляр Excel и вставьте приведенный ниже код в модуль.

КОД: (ПРОБОВАН И ИСПЫТАНО)

Я прокомментировал код, чтобы у вас не было проблем с его пониманием.

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 GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Private Declare Function GetWindowTextLength Lib "user32" Alias _
"GetWindowTextLengthA" (ByVal hwnd As Long) As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Dim Ret As Long, ChildRet As Long, OpenRet As Long
Dim strBuff As String, ButCap As String
Dim MyPassword As String

Const WM_SETTEXT = &HC
Const BM_CLICK = &HF5

Sub UnlockVBA()
    Dim xlAp As Object, oWb As Object

    Set xlAp = CreateObject("Excel.Application")

    xlAp.Visible = True

    '~~> Open the workbook in a separate instance
    Set oWb = xlAp.Workbooks.Open("C:\Sample.xlsm")

    '~~> Launch the VBA Project Password window
    '~~> I am assuming that it is protected. If not then
    '~~> put a check here.
    xlAp.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute

    '~~> Your passwword to open then VBA Project
    MyPassword = "Blah Blah"

    '~~> Get the handle of the "VBAProject Password" Window
    Ret = FindWindow(vbNullString, "VBAProject Password")

    If Ret <> 0 Then
        'MsgBox "VBAProject Password Window Found"

        '~~> Get the handle of the TextBox Window where we need to type the password
        ChildRet = FindWindowEx(Ret, ByVal 0&, "Edit", vbNullString)

        If ChildRet <> 0 Then
            'MsgBox "TextBox's Window Found"
            '~~> This is where we send the password to the Text Window
            SendMess MyPassword, ChildRet

            DoEvents

            '~~> Get the handle of the Button's "Window"
            ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)

            '~~> Check if we found it or not
            If ChildRet <> 0 Then
                'MsgBox "Button's Window Found"

                '~~> Get the caption of the child window
                strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
                GetWindowText ChildRet, strBuff, Len(strBuff)
                ButCap = strBuff

                '~~> Loop through all child windows
                Do While ChildRet <> 0
                    '~~> Check if the caption has the word "OK"
                    If InStr(1, ButCap, "OK") Then
                        '~~> If this is the button we are looking for then exit
                        OpenRet = ChildRet
                        Exit Do
                    End If

                    '~~> Get the handle of the next child window
                    ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
                    '~~> Get the caption of the child window
                    strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
                    GetWindowText ChildRet, strBuff, Len(strBuff)
                    ButCap = strBuff
                Loop

                '~~> Check if we found it or not
                If OpenRet <> 0 Then
                    '~~> Click the OK Button
                    SendMessage ChildRet, BM_CLICK, 0, vbNullString
                Else
                    MsgBox "The Handle of OK Button was not found"
                End If
            Else
                 MsgBox "Button's Window Not Found"
            End If
        Else
            MsgBox "The Edit Box was not found"
        End If
    Else
        MsgBox "VBAProject Password Window was not Found"
    End If
End Sub

Sub SendMess(Message As String, hwnd As Long)
    Call SendMessage(hwnd, WM_SETTEXT, False, ByVal Message)
End Sub