반응형
VB 코드에서 VBProject 보호 해제
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 프로젝트를 보호하는 것이 목표입니다.
도와주셔서 감사합니다.
편집:
이것을 VBA 및 VB용 블로그 투고로 변환.그물.
나는 결코 에 찬성한 적이 없다.Sendkeys어떤 경우에는 신뢰할 수 있지만 항상 신뢰할 수는 없습니다.저는 API를 아주 좋아합니다.
원하는 것을 달성할 수 있지만 VBA를 보호 해제하려는 워크북을 별도의 Excel 인스턴스에서 열어야 합니다.
여기 예가 있습니다.
현재 VBA 프로젝트와 같은 워크북이 있다고 가정해 보겠습니다.
논리:
다음을 사용하여 "VBAProject Password" 창의 핸들을 찾습니다.
FindWindow검색되면 다음 명령을 사용하여 해당 창에서 Edit Box 핸들을 찾습니다.
FindWindowExEdit Box의 핸들을 찾으면 다음 명령을 사용합니다.
SendMessage쓸 수 있게 해 주세요.의 핸들을 찾습니다.
Buttons를 사용하여 그 창에서FindWindowEx의 핸들이
OK버튼을 찾을 수 있습니다.단순히 사용하세요.SendMessage클릭해 주세요.
권장 사항:
API의 경우 이 링크가 추천할 수 있는 최고의 링크입니다.
API를 잘하고 싶다면
FindWindow,FindWindowEx그리고.SendMessage그러면 시스템 프로세스, 스레드, 창 및 창 메시지를 그래픽으로 볼 수 있는 도구를 얻을 수 있습니다.예: uuSpy 또는 Spy++.
Spy++는 "VBAProject Password" 창에 대해 다음과 같이 표시합니다.
테스트:
새 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
새로운 답변을 위해 이 코드를 잠근 것은 알고 있습니다만, 위의 코드(주로 Office 64비트(VBA7)에서 작업하고 있는 것)에 문제가 있었습니다.다만, 현재의 Excel 인스턴스에서 코드가 동작하도록 하고, 에러 체크를 조금 더 추가해, 메서드만으로 다른 모듈에 붙여 넣도록 포맷했습니다.UnlockProject노출되어 있습니다.
완전한 공개를 위해서, 이 투고의 코드로 시작했지만, 이것은 테마의 변형입니다.
또한 이 코드는 조건부 컴파일 상수를 나타내므로 Excel의 32비트 및 64비트 향과 동시에 호환되어야 합니다.이 페이지를 이용해서 알아냈어요
아무튼 여기 암호가 있습니다.누군가 도움이 되길 바랍니다.
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
@James Macadie의 답변(위)은 제가 찾은 것 중 최고입니다(32비트 Excel 365/2019를 실행하고 있습니다).
주의: 나는 당신이 반드시 가지고 있어야 한다는 것을 알았다.Application.ScreenUpdating = True다른 서브 또는 함수를 통해 제임스의 메서드를 호출합니다. 않으면, 「 」라고 하는 것이 일이 있습니다.Invalid procedure call or argument인 경우).error('debug-mode를 ).
이 솔루션은 다음 두 가지 방법보다 우수합니다.
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/. 불안정하고 여러 워크북에서 순차적으로 실행되면 실패할 수 있습니다.James 솔루션에 구현된 타이머/슬롯 루프가 부족하기 때문에 문제를 완전히 디버깅하지 않았습니다.
언급URL : https://stackoverflow.com/questions/16174469/unprotect-vbproject-from-vb-code
반응형
'programing' 카테고리의 다른 글
| XlsxWriter로 쓴 후 셀에 형식 적용 (0) | 2023.04.11 |
|---|---|
| x64 사용자 지정 클래스의 각 열거에 대한 버그 (0) | 2023.04.11 |
| Bash에서 명령줄 인수를 변경하려면 어떻게 해야 합니까? (0) | 2023.04.11 |
| Javascript 내보내기 CSV 인코딩 utf-8 문제 (0) | 2023.04.11 |
| git은 변경된 변경만 추가하고 추적되지 않은 파일은 무시합니다. (0) | 2023.04.11 |