|
|
小白求大神搭救 感谢；麻烦帮忙改一下回复。
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Dim sou_sec(20) As Integer
Dim rowArr(16, 10) As Byte
Dim colArr(16, 10) As Byte
Dim sec_key(20) As Integer
Dim errNo As Integer
Dim date_T As Date
Sub mail()
Dim MyMail As String
MyMail = "mailto:pengxiren922@163.com?subject=关于常用工具5.6的建议&body=" & "向您提出以下建议:"
ShellExecute 0&, vbNullString, MyMail, vbNullString, vbNullString, 1
End Sub
Sub 排序(arr, xx As Long, yy As Long, arr1) '合并式排序法
Dim z As Long
Dim j As Long
Dim X As Long
Dim Y As Long
Dim jj As Long
Dim i As Long
Dim temp
z = yy - xx + 1
If z = 1 Then Exit Sub
X = Fix(z / 2)
Call 排序(arr, xx, xx + X - 1, arr1)
Call 排序(arr, xx + X, yy, arr1)
If arr(xx + X - 1) <= arr(xx + X) Then Exit Sub '
For i = xx To xx + X - 1
arr1(i) = arr(i)
Next i
j = xx + X
jj = xx - 1
For i = xx To xx + X - 1
For j = j To yy
If arr(j) >= arr1(i) Then Exit For
jj = jj + 1
arr(jj) = arr(j)
Next j
jj = jj + 1
arr(jj) = arr1(i)
Next i
End Sub
''''''''''''''''''''''''''''''向下 excelhome:Qee版主提供的快速排序法
Sub 快速排序(p As Long, r As Long, L)
Const e = 6
Dim q As Long
If r - p <= e Then
Insertion_Sort L, p, r
Else
q = partition(p, r, L)
快速排序 p, q, L
快速排序 q + 1, r, L
End If
End Sub
Sub Insertion_Sort(L, p As Long, r As Long)
Dim i As Long, j As Long
Dim v
For i = p + 1 To r
v = L(i)
j = i
Do While j > p
If L(j - 1) < v Then Exit Do
L(j) = L(j - 1)
j = j - 1
Loop
L(j) = v
Next i
End Sub
Function partition(p As Long, r As Long, L) As Long
Dim i As Long, j As Long
Dim pivot
Dim swap
pivot = pivot + L(p + (r - p) * Rnd)
i = p - 1
j = r + 1
Do
Do
j = j - 1
If L(j) <= pivot Then Exit Do
Loop
Do
i = i + 1
If L(i) >= pivot Then Exit Do
Loop
If i < j Then
swap = L(j)
L(j) = L(i)
L(i) = swap
ElseIf j < r Then
partition = j: Exit Function
Else
partition = j - 1: Exit Function
End If
Loop
End Function
''''''''''''''''''''''''''''''向上excelhome:Qee版主提供的快速排序法
Sub 生成通用编码()
t = Timer
Dim d2 As New Dictionary, i As Long
arr = Range("A1:c" & [a65536].End(xlUp).Row)
For i = 2 To UBound(arr)
If d2.Exists(arr(i, 1)) Then
arr(d2(arr(i, 1)), 3) = arr(d2(arr(i, 1)), 3) & "," & i
arr(i, 3) = arr(i, 3) & "," & d2(arr(i, 1))
Else
d2(arr(i, 1)) = i
End If
Next i
For i = 2 To UBound(arr)
If d2.Exists(arr(i, 2)) Then
If d2(arr(i, 2)) <> i Then
arr(i, 3) = arr(i, 3) & "," & d2(arr(i, 2))
arr(d2(arr(i, 2)), 3) = arr(d2(arr(i, 2)), 3) & "," & i
End If
Else
d2(arr(i, 2)) = i
End If
Next i
ReDim arr2(1 To i * 2, 1 To 2)
For i = 2 To UBound(arr)
If arr(i, 1) <> "" Then
a = arr(i, 1)
arr(i, 1) = "" '走过的路不用再走
If arr(i, 3) <> "" Then
xi a, arr, i
Else
If a <> arr(i, 2) Then a = a & "," & arr(i, 2)
End If
arr1 = Split(a, ",")
For ii = 0 To UBound(arr1)
j = j + 1
arr2(j, 1) = arr1(ii)
arr2(j, 2) = a
Next
End If
Next i
Range("d1:e" & j) = arr2
MsgBox (Timer - t)
End Sub
Sub xi(a, arr, X)
arr1 = Split(arr(X, 3), ",")
For i = 1 To UBound(arr1)
If arr(arr1(i), 1) <> "" Then
If Not (a Like "*" & arr(arr1(i), 1) & "*") Then a = a & "," & arr(arr1(i), 1)
arr(arr1(i), 1) = ""
If arr(arr1(i), 3) <> "" Then
xi a, arr, arr1(i)
Else
If Not (a Like "*" & arr(arr1(i), 2) & "*") Then a = a & "," & arr(arr1(i), 2)
End If
End If
Next i
End Sub
Private Sub CalFileCreateDate(txtFileName)
Dim k As Byte
Dim s1 As String
Dim no1_H As String
Dim no2_H As String
Dim no2_L As String
Dim locate_2_H As Integer
Dim locate_2_L As Integer
Dim locate_1_H As Integer
Dim count As Integer
count = 0
errNo = 0
no2_H = "32107654BA98FEDC"
no2_L = "EFCDAB8967452301"
no1_H = "67452301EFCDAB89"
Dim cchh(2) As Byte
Dim fileNo As Long
fileNo = FreeFile
Open txtFileName For Binary Access Read As #fileNo Len = 3
Get #fileNo, &H77, cchh
Close #fileNo
If cchh(2) >= &HBC And cchh(2) <= &HBF Then
s1 = "7/1/78"
count = 4
k = &HBC
End If
If cchh(2) >= &H80 And cchh(2) <= &H8F Then
s1 = "9/17/1989"
count = 2
k = &H80
End If
If cchh(2) >= &H90 And cchh(2) <= &H91 Then
s1 = "6/5/2079"
count = 1
k = &H90
End If
If count = 0 Then
MsgBox txtFileName & "不是ACCESS2000数据库或出错！"
errNo = 1
Exit Sub
End If
locate_2_H = InStr(no2_H, Mid(Hex2(cchh(1)), 1, 1))
locate_2_L = InStr(no2_L, Mid(Hex2(cchh(1)), 2, 1))
locate_1_H = (InStr(no1_H, Mid(Hex2(cchh(0)), 1, 1)) - 1) \ count
date_T = DateValue(s1) + (cchh(2) - k) * 1024 * 4 / count + (locate_2_H - 1) * 16 * 4 * (4 / count) + (locate_2_L - 1) * 4 * (4 / count) + locate_1_H
End Sub
Private Function Hex2(ByVal b As Byte) As String
If Len(Hex(b)) = 1 Then
Hex2 = "0" & UCase(Hex(b))
Else
Hex2 = UCase(Hex(b))
End If
End Function
Function pmm(txtFileName)
On Error GoTo doErr
Dim ch(40) As Byte
Dim i As Integer, iChar As Integer
Dim fileNo As Long
If Trim(txtFileName) = "" Then Exit Function
CalFileCreateDate (txtFileName)
If errNo = 1 Then Exit Function
GetPWD
txtPWD = ""
fileNo = FreeFile
Open txtFileName For Binary Access Read As #fileNo Len = 40
Get #fileNo, &H43, ch
Close #fileNo
For i = 0 To 39 Step 2
iChar = ch(i) Xor sec_key(Int(i / 2))
txtPWD = txtPWD & Chr(iChar)
Next i
pmm = txtPWD
Exit Function
doErr:
MsgBox Err.Description
Exit Function
End Function
Sub 破数据库密码()
txtFileName = Application.GetOpenFilename
If Not (txtfliename Like "*.mdb") Then Exit Sub
On Error GoTo doErr
Dim ch(40) As Byte
Dim i As Integer, iChar As Integer
Dim fileNo As Long
If Trim(txtFileName) = "" Then Exit Sub
CalFileCreateDate (txtFileName)
If errNo = 1 Then Exit Sub
GetPWD
txtPWD = ""
fileNo = FreeFile
Open txtFileName For Binary Access Read As #fileNo Len = 40
Get #fileNo, &H43, ch
Close #fileNo
For i = 0 To 39 Step 2
iChar = ch(i) Xor sec_key(Int(i / 2))
txtPWD = txtPWD & Chr(iChar)
Next i
MsgBox (txtPWD)
Exit Sub
doErr:
MsgBox Err.Description
Exit Sub
End Sub
Private Sub GetPWD()
Dim i As Long
Dim j As Integer, k As Integer
Dim guoding()
EnterArray
i = DateSerial(Year(date_T), Month(date_T), Day(date_T)) - DateSerial(1979, 12, 27)
If i < 0 Then Exit Sub
If i <= 36320 Then
guoding = Array(&HEC, &H9C, &H28, &H8A, &H7B, &HDF, &H13, &HB1, &H79, &H7C)
Else
guoding = Array(&HED, &H9D, &H29, &H8B, &H7A, &HDE, &H12, &HB0, &H78, &H7D)
End If
i = i Mod 256
j = i \ 16
k = i Mod 16
For i = 0 To 9
sec_key(i * 2) = rowArr(j, i) * 16 + colArr(k, i)
sec_key(i * 2 + 1) = guoding(i)
Next i
End Sub
Private Sub EnterArray()
Dim i As Integer, j As Integer, k As Integer, ch As String * 1
Dim sou_col_str()
Dim sou_row_str()
sou_col_str = Array("6D63457F42", "7C72546E53", "4F41675D60", "5E50764C71", "2927013B06", "3836102A17", "0B05231924", "1A14320835", "E5EBCDF7CA", "F4FADCE6DB", "C7C9EFD5E8", "D6D8FEC4F9", "A1AF89B38E", "B0BE98A29F", "838DAB91AC", "929CBA80BD")
sou_row_str = Array("A7E37D5E1B", "B6F26C4F0A", "C1851B387D", "D0940A296C", "E3A7391A5F", "F2B6280B4E", "0D49D7F4B1", "1C58C6E5A0", "2F6BF5D693", "3E7AE4C782", "490D93B0F5", "581C82A1E4", "6B2FB192D7", "7A3EA083C6", "85C15F7C39", "94D04E6D28")
For i = 0 To 15
For j = 0 To 9
ch = Mid(sou_col_str(i), j + 1, 1)
colArr(i, j) = "&H" & ch
ch = Mid(sou_row_str(i), j + 1, 1)
rowArr(i, j) = "&H" & ch
Next j
Next i
End Sub
|
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2022-12-12 00:07
