07
--
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
--
>>
<<
--
LATEST ENTRY
CATEGORY
ARCHIVE
PROFILE
SEARCH
RECENT COMMENT
MOBILE
qrcode
OTHERS
<< 【MODx】XAMPP + Eclipse + ZendDebugger で MODxの内部探検【ハック】 | top | Excel の パスワード解除 (VBS版) >>
エクセルファイルのパスワードを忘れたら・・・

本日夕方、友人からTELが

パスワードをかけたエクセルが開けなくなっちゃった・・・

とのことで、パスワード解除のプログラム作ってみました

ファイルは無料サイトにおいてあります

コチラ http://drop.io/o8pckmr を開いて ExcelPassUnlock.zip をダウンロードしてください

このファイル、最終アクセスから1年間だれもさわらないと自動で削除されちゃいます
ダウンロードできなかったら削除されたものと思ってください・・

ファイルはパスワードの長さを指定して、その長さに合わせていろんな文字を組み合わせてファイルが開けるかを確認するマクロです


エクセルとかオフィス系ソフトって、パスワードかけておかないと危ないけど、
パスワードって間違えたり忘れちゃったり、パスワード知ってる担当者がいなくなっちゃったり・・

開けなくなったりするんですよねーー


パスワードを知ってれば開けるファイルなら、非常に時間はかかりますが確実にパスワードを探してくれるはずです


内部処理では再帰してるので、あまり長いとスタック不足になるかも??


エラーが出たら、コメントにでも書いてください

余裕があれば調査して直してみます




とりあえずやっつけで作ったので汚いソースですが、
マクロわかる方ならこれだけ残しておけば
エクセルのパスワード解除マクロを再生できると思うので、ソースも公開しときます

自由に使ってやってください

Option Explicit
Global Const cmax As Integer = 10
Global Const cmin As Integer = 1
Global fp As String
Global sttime As Date

Sub passUnlock(pass As String, paslen As Integer)
    Application.DisplayAlerts = False
    On Error Resume Next
    If Len(pass) >= paslen Then Exit Sub
    Dim i As Long
    Dim p As String
    For i = &H20 To &H7F
        If Len(pass & Chr(i)) <> paslen Then
            Call passUnlock(pass & Chr(i), paslen)
        Else
            Err.Clear
            p = Chr(i)
            Application.StatusBar = pass & p
            DoEvents
            Workbooks.Open filename:=fp, Password:=pass & p
            If Err.Number = 0 Then
                Call passMessage("パスワードを解除しました。[ " & pass & p & " ]")
                End
            End If
        End If
    Next i
End Sub

Sub passMessage(msg)
    Dim i
    Dim k As Double
    Dim h, m, s
   
    k = DateDiff("s", sttime, Now)
    h = Application.RoundDown(k / (60 * 60), 0)
    m = Application.RoundDown(((k - (h * 60 * 60)) / 60), 0)
    s = (k - (h * 60 * 60) - (m * 60))
   
    i = MsgBox(msg & vbCrLf & _
                Format(sttime, "yyyy/mm/dd HH:NN:SS") & _
                Format(Now, " 〜 yyyy/mm/dd HH:NN:SS") & vbCrLf & _
                "所要時間  " & h & "時間 " & m & "分 " & s & "秒", _
                vbInformation)
    Application.StatusBar = False
    End
End Sub

Private Sub CommandButton1_Click()
    Dim max As Integer
    Dim min As Integer
    Dim i As Integer
    Dim filename
   
    Do While True
        filename = Application.GetOpenFilename("Excel (*.xls),*.xls", , "パスワードを解除するファイルを選択してください。", , 0)
        If filename = False Then
            filename = MsgBox("ファイルを選択してください。", vbCritical + vbOKCancel)
            If filename = vbCancel Then
                End
            End If
        ElseIf LCase(Right(filename, 4)) = ".xls" Then
            Exit Do
        Else
            filename = MsgBox("エクセルファイルを選択してください。", vbCritical + vbOKCancel)
            If filename = vbCancel Then
                End
            End If
        End If
    Loop
   
    On Error Resume Next
    Application.DisplayAlerts = False
    max = CInt(ActiveSheet.Range("MAXLEN").Text)
    min = CInt(ActiveSheet.Range("MINLEN").Text)
    If max = 0 Then max = cmax
    If min = 0 Then min = cmin
    fp = filename
    sttime = Now
    For i = min To max
        Call passUnlock("", i)
    Next i
End Sub

Private Sub CommandButton2_Click()
    Call passMessage("パスワード解除を停止しました。")
    End
End Sub
 


いろいろと改善できる部分はありますが、とりあえず動けば良いかな・・というレベルです


3桁のパスワード解除に私のマシンでは9分近くかかりました


8桁とか10桁とか・・ 何時間かかるんだろう・・・



 

まこ | 開発 | 21:03 | comments(4) | trackbacks(0) |
スポンサーサイト
スポンサードリンク | - | 21:03 | - | - |
Comment
エクセルのパスワード介助のファイルが無料サイトにありません。
再度アップして頂けますでしょうか?

posted by ヤナト ,2015/07/07 9:37 PM

たった今…コメントレス確認いたしました!!もし既にメールにご連絡いただけているようでしたら…再送していただけませんか?大量にメール受信するため…見落としている可能性大です<(_ _)>

posted by さー ,2010/05/24 12:07 AM

さー さま
コメントありがとうございます

文字を限定したバージョンの製作承りました。
完成次第ご連絡させていただきます。

posted by まこ ,2010/05/19 12:54 AM

お願いがあります…アルファベットと数字と「-」「_」しか使っていないソースを書いていただくことは可能でしょうか?謝礼お支払いいたします。

posted by さー ,2010/05/16 6:35 PM










Trackback
URL: