麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 如何透過 VBA語法開啟專案的密碼 [打印本頁]

作者: jsleee 時間: 2012-7-3 19:13 標題: 如何透過 VBA語法開啟專案的密碼

請教各位先進
如果我想透過 VBA 語法在開啟其他Excel檔案時，自動將其專案的密碼打開
換句話說，這些 Excel 檔案的專案密碼我都清楚，只是懶得一個一個手動輸入....
不知道先進們能否協助提供該語法....
我在網路上看到的都是要破解的動作，但我不需要破解，因為密碼本來就知道，
只是想自動打開罷了....

謝謝

JS

作者: kimbal 時間: 2012-7-3 23:47

這個是模擬鍵盤的方法:

Sub UnprotectVBProj(ByVal Pwd As String, wb As Workbook)
Dim vbProj As Object
Set vbProj = wb.VBProject
If vbProj.Protection <> 1 Then Exit Sub ' already unprotected
Set Application.VBE.ActiveVBProject = vbProj
SendKeys Pwd & "~~"
Application.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
End Sub

複製代碼

用法 "ABC" 為密碼, wb為對方活頁簿
CALL UnprotectVBProj("ABC", wb)

作者: jsleee 時間: 2012-7-4 09:08

回復 2# kimbal

謝謝 kimbal 先進的回覆，很抱歉我實在試不出來，
所以我將檔案附上來，當我想要利用附件檔案開啟某個目錄中的全部檔案
同時將每個檔案中的專案密碼(假設是 ABC) 開啟，
不知道程式碼該如何結合在一起？
煩請抽空再協助一下，感激不盡

JS[attach]11569[/attach]

作者: oobird 時間: 2012-7-4 13:44

Sub yy()
p = [b1] & "\"
f = Dir(p & [b2])
Do While f <> ""
Workbooks.Open p & f, Password:="abc"
f = Dir
Loop
End Sub

複製代碼

作者: jsleee 時間: 2012-7-4 18:59

回復 4# oobird

請教 oobird 先進，您提供的程式碼是否是開啟活頁部的密碼？
我目前要開啟的是 VBA專案中的程式碼的密碼....
是否有一樣？煩請解惑....
謝謝

佳欣

作者: jsleee 時間: 2012-7-26 07:49

請教先進
   我在 #3 所附上的例子是否有解？
   我的目的是要用一個 Excel檔案，逐一開啟指定目錄中的所有Excel檔案，
   同時將這些檔案的 VBA專案密碼解開....
   希望有先進可以指點一下，感恩
JS

作者: jsleee 時間: 2012-7-30 21:22

前面所提的密碼是已經知道密碼值，
只是希望透過另一個程式來將原本鎖住的 VBA專案密碼打開
不知道程式碼該如何呈現？？？

JS

作者: Hsieh 時間: 2012-7-30 23:07

回復 7# jsleee

#3的程序就能解除鎖定

Sub 開啟檔案()
Dim CurrentPath As String '儲存目前檔案目錄
Dim OpenFN As String '讀取到的檔案名稱
Dim FNExt As String '檔案副檔名
Dim MyBook As Workbook
FN = ActiveWorkbook.Name
CurrentPath = Range("B1") '如果有設定以設定為主
FNExt = Range("b2") '查詢檔案類型
If Trim(CurrentPath) = "" Then
CurrentPath = Excel.ActiveWorkbook.Path
End If
n = 0
Sheets("trans").Cells.Delete '將之前的結果清除
If Right(CurrentPath, 1) = "\" Then
OpenFN = Dir(CurrentPath & FNExt, vbDirectory)
OpenFNTime = CurrentPath
Else
OpenFN = Dir(CurrentPath & "\" & FNExt, vbDirectory)
OpenFNTime = CurrentPath & "\"
End If
While OpenFN <> ""
If OpenFN <> ActiveWorkbook.Name Then '這個檔案不要顯示
If OpenFN <> "." And OpenFN <> ".." Then
n = n + 1
fs = OpenFNTime & OpenFN
Sheets("trans").Cells(n, 7).Value = fs
Workbooks.Open(Filename:=OpenFNTime & OpenFN _
, Password:="msign").RunAutoMacros Which:=xlAutoOpen
Set MyBook = ActiveWorkbook
UnprotectVBProj "password", MyBook '請自行修改密碼
End If
End If
OpenFN = Dir() '讀取下一個檔案
Wend
Workbooks(FN).Close savechanges:=False
End Sub
Sub UnprotectVBProj(ByVal Pwd As String, wb As Workbook)
Dim vbProj As Object
Set vbProj = wb.VBProject
If vbProj.Protection <> 1 Then Exit Sub ' already unprotected
Set Application.VBE.ActiveVBProject = vbProj
SendKeys Pwd & "~~"
Application.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
End Sub

複製代碼

作者: jsleee 時間: 2012-7-31 21:29

回復 8# Hsieh

謝謝 Hsieh 超級版主的協助，我的問題已經全部解決了
感恩

JS

作者: jsleee 時間: 2012-8-4 17:07

回復 8# Hsieh

再請教超級版主兩個延伸的問題：
1. 程式執行完後，會留下附件的圖片畫面，能否讓他自動關閉？
2. 如果一次開啟多個檔案，好像只有一個檔案可以解開專案密碼，
其他檔案還是沒有解開，不知道哪裡出問題？？
再麻煩您協助解惑，謝謝

JS

作者: jsleee 時間: 2012-8-8 21:51

本帖最後由 jsleee 於 2012-8-8 21:53 編輯

回復 8# Hsieh

請教超級版主 Hsieh
      我在 10# 所提的問題不知道有無解？
      目前使用迴圈開啟同一目錄中的多個檔案，
      都只有其中一個檔案可以正常開啟專案密碼，
      其餘檔案都只有開啟Excel檔，專案密碼沒有開啟？？？
      (ps. 每一個檔案的檔案密碼 & VBA專案密碼都是一樣的....)
      希望超級版主能夠撥空解惑，謝謝
JS

作者: Hsieh 時間: 2012-8-8 23:15

Sub 開啟檔案()
Dim CurrentPath As String '儲存目前檔案目錄
Dim OpenFN As String '讀取到的檔案名稱
Dim FNExt As String '檔案副檔名
Dim MyBook As Workbook
FN = ActiveWorkbook.Name
CurrentPath = Range("B1") '如果有設定以設定為主
FNExt = Range("b2") '查詢檔案類型
If Trim(CurrentPath) = "" Then
CurrentPath = Excel.ActiveWorkbook.Path
End If
n = 0
Sheets("trans").Cells.Delete '將之前的結果清除
If Right(CurrentPath, 1) = "\" Then
OpenFN = Dir(CurrentPath & FNExt, vbDirectory)
OpenFNTime = CurrentPath
Else
OpenFN = Dir(CurrentPath & "\" & FNExt, vbDirectory)
OpenFNTime = CurrentPath & "\"
End If
While OpenFN <> ""
If OpenFN <> ActiveWorkbook.Name Then '這個檔案不要顯示
If OpenFN <> "." And OpenFN <> ".." Then
n = n + 1
fs = OpenFNTime & OpenFN
Workbooks(FN).Sheets("trans").Cells(n, 7).Value = fs
Workbooks.Open(Filename:=OpenFNTime & OpenFN _
, Password:="msign").RunAutoMacros Which:=xlAutoOpen
Pwd = "1234" '自行修改密碼
SendKeys Pwd & "~"
Application.CommandBars(16).FindControl(ID:=1561, recursive:=True).Execute
End If
End If
OpenFN = Dir() '讀取下一個檔案
Wend
Workbooks(FN).Close savechanges:=False
End Sub

複製代碼

回復 11# jsleee

作者: jsleee 時間: 2012-8-9 07:54

回復 12# Hsieh

不好意思，再請教超級版主....
我將程式碼複製到檔案中，然後修該密碼後，執行到第 34行，
Application.CommandBars(16).FindControl(ID:=1561, recursive:=True).Execute
就會出現錯誤訊息 "執行階段錯誤 '91' ，沒有設定物件變數或 With 區塊變數"？？？
另外請教，上述程式碼34行中，所代表的含意是甚麼？
CommandBars(16) 中的 16 有無特別意義？
ID:=1561 中的 1561 有無特別意義？

以上請教，謝謝

JS

作者: Hsieh 時間: 2012-8-9 08:59

回復 13# jsleee

這是在2003版中可以執行的程式碼
不同版本請執行下列程式碼
取得對應ID

Sub nn()
Dim cmb As CommandBar
For Each cmb In Application.CommandBars
For Each ob In cmb.Controls
r = r + 1
Cells(r, 1).Resize(, 3) = Array(ob.Caption, cmb.Index, ob.ID)
Next
Next
End Sub

複製代碼

[attach]12065[/attach]

作者: jsleee 時間: 2012-8-9 22:02

回復 14# Hsieh

感謝超級版主的教導，真是令人開了眼界....
原來 VBA 還有這麼多寶藏，真是高深莫測....

   另外一個問題，我在測試的過程，偶爾會有 Sendkeys 失效的狀況 (我猜測的)
   因為測試連續開啟目錄中 7 個檔案，其中就發生三個檔案需要人工輸入 VBA專案密碼？？？
   請問這樣正常嗎？
   是否因為 Sendkeys 執行過程時間差問題導致密碼沒有 send 成功？？？
   很抱歉，雖然一步一步朝目標邁進，不過還是有遇到問題.....
   煩請解惑，謝謝
JS

作者: Hsieh 時間: 2012-8-9 23:08

回復 15# jsleee
SendKeys方法加上wait參數試試看

Sub 開啟檔案()
Dim CurrentPath As String '儲存目前檔案目錄
Dim OpenFN As String '讀取到的檔案名稱
Dim FNExt As String '檔案副檔名
Dim MyBook As Workbook
FN = ActiveWorkbook.Name
CurrentPath = Range("B1") '如果有設定以設定為主
FNExt = Range("b2") '查詢檔案類型
If Trim(CurrentPath) = "" Then
CurrentPath = Excel.ActiveWorkbook.Path
End If
n = 0
Sheets("trans").Cells.Delete '將之前的結果清除
If Right(CurrentPath, 1) = "\" Then
OpenFN = Dir(CurrentPath & FNExt, vbDirectory)
OpenFNTime = CurrentPath
Else
OpenFN = Dir(CurrentPath & "\" & FNExt, vbDirectory)
OpenFNTime = CurrentPath & "\"
End If
While OpenFN <> ""
If OpenFN <> ActiveWorkbook.Name Then '這個檔案不要顯示
If OpenFN <> "." And OpenFN <> ".." Then
n = n + 1
fs = OpenFNTime & OpenFN
Workbooks(FN).Sheets("trans").Cells(n, 7).Value = fs
Workbooks.Open(Filename:=OpenFNTime & OpenFN _
, Password:="msign").RunAutoMacros Which:=xlAutoOpen
Pwd = "1234" '自行修改密碼
SendKeys Pwd & "~", True
Application.CommandBars(16).FindControl(ID:=1561, recursive:=True).Execute
End If
End If
OpenFN = Dir() '讀取下一個檔案
Wend
Workbooks(FN).Close savechanges:=False
End Sub

複製代碼

作者: jsleee 時間: 2012-8-10 13:02

回復 16# Hsieh

不好意思，測試結果無效....

作者: Hsieh 時間: 2012-8-10 21:34

回復 17# jsleee

是某些固定檔案會發生這樣的情形嗎?
如果是，我猜可能是檔案開啟時間較長
結果程式先跑到檢視程式碼，然後才完成檔案開啟
試試用sleep停頓數秒後再繼續往下執行試試看是否有改善

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub 開啟檔案()
Dim CurrentPath As String '儲存目前檔案目錄
Dim OpenFN As String '讀取到的檔案名稱
Dim FNExt As String '檔案副檔名
Dim MyBook As Workbook
FN = ActiveWorkbook.Name
CurrentPath = Range("B1") '如果有設定以設定為主
FNExt = Range("b2") '查詢檔案類型
If Trim(CurrentPath) = "" Then
CurrentPath = Excel.ActiveWorkbook.Path
End If
n = 0
Sheets("trans").Cells.Delete '將之前的結果清除
If Right(CurrentPath, 1) = "\" Then
OpenFN = Dir(CurrentPath & FNExt, vbDirectory)
OpenFNTime = CurrentPath
Else
OpenFN = Dir(CurrentPath & "\" & FNExt, vbDirectory)
OpenFNTime = CurrentPath & "\"
End If
While OpenFN <> ""
If OpenFN <> ActiveWorkbook.Name Then '這個檔案不要顯示
If OpenFN <> "." And OpenFN <> ".." Then
n = n + 1
fs = OpenFNTime & OpenFN
Workbooks(FN).Sheets("trans").Cells(n, 7).Value = fs
Workbooks.Open(Filename:=OpenFNTime & OpenFN _
, Password:="msign").RunAutoMacros Which:=xlAutoOpen
Sleep 200 '暫停2秒
Pwd = "1234" '自行修改密碼
CId = IIf(Application.Version = 11, 16, 42)
Set vbProj = ActiveWorkbook.VBProject
If vbProj.Protection <> 1 Then GoTo 10
SendKeys Pwd & "~", True
Application.CommandBars(CId).FindControl(ID:=1561, recursive:=True).Execute
End If
End If
10
OpenFN = Dir() '讀取下一個檔案
Wend
SendKeys "%{F11}" '離開VBE
' Workbooks(FN).Close savechanges:=False
End Sub

複製代碼

作者: jsleee 時間: 2012-8-11 20:33

回復 18# Hsieh

超級版主您好
         測試好幾次都失敗，密碼會被傳送到工作表中，無法送到 VBA專案密碼的對話框....
         另外請教，Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
         這一行宣告不太了解他的意思？因為 Sleep 的功能好像沒有感覺到....

JS

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)