word解密.frm

可以破解由数字和大小写字母和各类符号组成的word或excel的密码。

Private Sub CmdQuit_Click()
End
End Sub

Private Sub CmdStartCrack_Click()
Dim wd As New Word.Application
'Dim xls As New Excel.Application
Dim OpenReturn
Dim strpath, pass, all_char(100) As String
Dim J, K, Password_Start_Long, Password_End_Long, ArrayLen As Integer
Dim I, Temp As Long
If Optforce.Value = True Then
     '数组初始化
    ArrayLen = 0
    If Chkdigital.Value = 1 Then
        For J = ArrayLen To ArrayLen + 9
            all_char(J) = Chr(Asc("0") + J - ArrayLen)
        Next J
        ArrayLen = ArrayLen + 10
    End If
    If Chklowercase.Value = 1 Then
        For J = ArrayLen To ArrayLen + 25
            all_char(J) = Chr(Asc("a") + J - ArrayLen)
        Next J
        ArrayLen = ArrayLen + 26
    End If
    If Chkuppercase.Value = 1 Then
        For J = ArrayLen To ArrayLen + 25
            all_char(J) = Chr(Asc("A") + J - ArrayLen)
        Next J
        ArrayLen = ArrayLen + 26
    End If
    If Chkspace.Value = 1 Then
        all_char(ArrayLen) = " "
        ArrayLen = ArrayLen + 1
    End If
    If Chkbracket.Value = 1 Then
        all_char(ArrayLen) = "("
        all_char(ArrayLen + 1) = ")"
        all_char(ArrayLen + 2) = "{"
        all_char(ArrayLen + 3) = "}"
        all_char(ArrayLen + 4) = "["
        all_char(ArrayLen + 5) = "]"
        ArrayLen = ArrayLen + 6
    End If
    If Chkothers.Value = 1 Then
        For J = ArrayLen To ArrayLen + 6 '33 to 39
            all_char(J) = Chr(33 + J - ArrayLen)
        Next J
        ArrayLen = ArrayLen + 7
        For J = ArrayLen To ArrayLen + 5 '42 to 47
            all_char(J) = Chr(42 + J - ArrayLen)
        Next J
        ArrayLen = ArrayLen + 6
        For J = ArrayLen To ArrayLen + 6 '58 to 64
            all_char(J) = Chr(58 + J - ArrayLen)
        Next J
        ArrayLen = ArrayLen + 7
        all_char(ArrayLen) = Chr(92)
        ArrayLen = ArrayLen + 1
        For J = ArrayLen To ArrayLen + 2 '94 to 96
            all_char(J) = Chr(94 + J - ArrayLen)
        Next J
        ArrayLen = ArrayLen + 3
        all_char(ArrayLen) = Chr(124)
        all_char(ArrayLen + 1) = Chr(126)
        ArrayLen = ArrayLen + 2
    End If
    If ArrayLen = 0 Then
        MsgBox "错误：没有选择'密码使用的字符'", , "请选择密码使用的字符范围..."
        Exit Sub
    End If
    '开始破解
    If blnProcessing Then
        If MsgBox("真的要中断解密过程吗？", vbYesNo, "用户中断任务") = vbYes Then blnProcessing = False
    Else
        Cmdstartcrack.Caption = "中断破解"
        blnProcessing = True
        strpath = Combo1.Text
        Call able
        If strpath = "" Then
            MsgBox "错误：没有选择'需要解密的文件'", , "请选择需要解密的文件……"
            Exit Sub
        End If
        strpath = Trim(strpath)
        Password_Start_Long = Val(Txtpasswordstartlong.Text)
        Password_End_Long = Val(Txtpasswordendlong.Text)
        If Password_Start_Long > Password_End_Long Then
            Password_Start_Long = Val(Txtpasswordendlong.Text)
            Password_End_Long = Val(Txtpasswordstartlong.Text)
        End If
        Lblpgs.Caption = "破解进度："
        Lblpgs.Refresh
        On Error Resume Next
        If UCase(Right(strpath, 3)) = "XLS" Then
'            For K = Password_Start_Long To Password_End_Long '破解Excel开始
'                For I = 0 To ArrayLen ^ K - 1
'                    pass = ""
'                    Temp = I
'                    For J = 1 To K - 1
'                        Temp = Temp \ ArrayLen
'                        pass = all_char(Temp Mod ArrayLen) + pass
'                    Next J
'                    pass = pass + all_char(I Mod ArrayLen)
'                    Set OpenReturn = xls.workbooks.Open(FileName:=strpath, Password:=pass)
'                    Text1.Text = pass '显示破解进度
'                    Text1.Refresh
'                    If Err.Number <> 0 Then '如果解密成功,打开文档,显示密码,退出过程
'                        Err.Clear
'                    Else
'                        Label1.Caption = "文档密码："
'                        Text1.Text = pass
'                        Me.Refresh
'                        xls.Visible = True
'                        Cmdstartcrack.MousePointer = 0
'                        Cmdstartcrack.Caption = "开始破解"
'                        blnProcessing = False
'                        Set xls = Nothing
'                        Exit Sub
'                    End If
'                    DoEvents
'                    If Not blnProcessing Then Exit For
'                Next I
'                If Not blnProcessing Then Exit For
'            Next K
'            xls.Quit
'            Set xls = Nothing
        ElseIf UCase(Right(strpath, 4)) = ".DOC" And Dir(strpath) <> "" And InStr(strpath, "*") = 0 Then
            For K = Password_Start_Long To Password_End_Long '破解word开始
                For I = Val(Text1.Text) To ArrayLen ^ K - 1
                    pass = ""
                    Temp = I
                    pass = all_char(I Mod ArrayLen)
                    For J = 1 To K - 1
                        Temp = Temp \ ArrayLen
                        pass = all_char(Temp Mod ArrayLen) + pass
                    Next J
                    OpenReturn = wd.Documents.Open(FileName:=strpath, passworddocument:=pass)
                    Text1.Text = pass '显示破解进度
                    Text1.Refresh
                    If Err.Number <> 0 Then '如果解密成功,打开文档,显示密码,退出过程
                        Err.Clear
                    Else
                        'MsgBox "word password"
                        Lblpgs.Caption = "文档密码："
                        Text1.Text = pass
                        Me.Refresh
                        wd.Visible = True
'                        Cmdstartcrack.MousePointer = 0
                        Cmdstartcrack.Caption = "开始破解"
                        blnProcessing = False
                        Call able
                        Set wd = Nothing
                        Exit Sub
                    End If
                    DoEvents
                    If Not blnProcessing Then Exit For
                Next I
                If Not blnProcessing Then Exit For
            Next K
            wd.Quit
            Set wd = Nothing
        Else
            MsgBox "请重新选择文档", vbCritical, "提示信息……"
            blnProcessing = False
        End If
        Cmdstartcrack.Caption = "开始破解"
        Call able
        If blnProcessing Then
            MsgBox "没有找到密码，可能是密码位数不对！", , "提示信息……"
            blnProcessing = False
        End If
    End If
Else
    If blnProcessing Then
        If MsgBox("真的要中断解密过程吗？", vbYesNo, "用户中断任务") = vbYes Then blnProcessing = False
    Else
        Cmdstartcrack.Caption = "中断破解"
        blnProcessing = True
        If strpath = "" Then
            MsgBox "错误：没有选择'需要解密的文件'", , "请选择需要解密的文件……"
            Exit Sub
        End If
        strpath = Trim(strpath)
        Password_Start_Long = Val(Txtpasswordstartlong.Text)
        Password_End_Long = Val(Txtpasswordendlong.Text)
        If Password_Start_Long > Password_End_Long Then
            Password_Start_Long = Val(Txtpasswordendlong.Text)
            Password_End_Long = Val(Txtpasswordstartlong.Text)
        End If
        Lblpgs.Caption = "破解进度："
        Lblpgs.Refresh
        On Error Resume Next
        If UCase(Right(strpath, 3)) = "XLS" Then
        '........
        ElseIf UCase(Right(strpath, 4)) = ".DOC" And Dir(strpath) <> "" And InStr(strpath, "*") = 0 Then
            pass = ""
            OpenReturn = wd.Documents.Open(FileName:=strpath, passworddocument:=pass)
            Text1.Text = pass '显示破解进度
            Text1.Refresh
            If Err.Number <> 0 Then '如果解密成功,打开文档,显示密码,退出过程
                Err.Clear
            Else
                'MsgBox "word password"
                Lblpgs.Caption = "文档密码："
                Text1.Text = pass
                Me.Refresh
                wd.Visible = True
'                        Cmdstartcrack.MousePointer = 0
                Cmdstartcrack.Caption = "开始破解"
                blnProcessing = False
                Call able
                Set wd = Nothing
                Exit Sub
            End If
            DoEvents
            wd.Quit
            Set wd = Nothing
        Else
            MsgBox "请重新选择文档", vbCritical, "提示信息……"
            blnProcessing = False
        End If

        End If
    End If
End Sub

Private Sub able()
Cmdbrowse.Enabled = Not blnProcessing
Combo1.Enabled = Not blnProcessing
Chkdigital.Enabled = Not blnProcessing
Chklowercase.Enabled = Not blnProcessing
Chkuppercase.Enabled = Not blnProcessing
Chkspace.Enabled = Not blnProcessing
Chkbracket.Enabled = Not blnProcessing
Chkothers.Enabled = Not blnProcessing
Frafile.Enabled = Not blnProcessing
Fralen.Enabled = Not blnProcessing
Frarange.Enabled = Not blnProcessing
Txtpasswordstartlong.Enabled = Not blnProcessing
Txtpasswordendlong.Enabled = Not blnProcessing
End Sub

Private Sub Combo1_Change()
Text1.Text = "0"
End Sub

Private Sub Frarange_Click()
Text1.Text = "0"
End Sub

Private Sub Optdic_Click()
Dim f%, l%
Dialog.DialogTitle = "选择字典文件"
Dialog.Filter = "Txt Files(*.txt)|*.txt"
Dialog.ShowOpen
dicpath = Dialog.FileName
If dicpath = "" Then
    MsgBox "错误：没有选择""字典文件""", , "请选择字典文件……"
    Exit Sub
End If
f = FreeFile
Open dicpath For Input As f
ReDim dictxt(1)
Do Until EOF(f)
    ReDim Preserve dictxt(0 To UBound(dictxt) + 1)
    l = l + 1
    Line Input #f, dictxt(l)
    dictxt(l) = Trim(dictxt(l))
Loop
blnProcessing = True
Call able
blnProcessing = False
End Sub

Private Sub Optforce_Click()
Erase dictxt()
Call able
End Sub

Private Sub Txtpasswordendlong_Change()
Text1.Text = "0"
End Sub

Private Sub Txtpasswordstartlong_Change()
Text1.Text = "0"
End Sub