1/ Mạnh đang thắc mắc 1 chút tại sao File của Bài này lại không Unlock được cho file bài 1
Trong class cBinEditor ở bài 1 có code
If strTemp = "CMG=""" Or strTemp = "DPB=""" Or strTemp Like "GC=""*" ThenTôi cũng biết là lỗi do tiếng Việt có dấu nhưng vẫn chưa có cách xử lý với việc nén (class cArchiver). Có lẽ phải đổi thuật toán ở sub 'LockCode'
Hóng
File *.xlam ở bài #1 cũng là loại file ở chủ đề
Theo như tôi được biết thì file XLSB không thể giải nén được (chỉ XLSX và XLSM mới giải nén được). Vậy nên nếu file XLSB được khóa theo kiểu Project Unview mà dùng cách giải nén để thay đổi nội dụng bên trong là thua
Em làm trên Máy Em thấy ok ... nhưng cũng chỉ làm cho vui và nghiên cứu là chính thôi anh...
Rem ==========
Private Sub LockUnlocProject(ByVal strBinaryFile As String, ByVal LockUlock As Boolean)
If LockUlock Then
Call ChangeKeys(strBinaryFile, True)
Else
Call ChangeKeys(strBinaryFile, False)
End If
End Sub
Rem ==========
Private Function FixPath(ByVal sPath As String) As String
FixPath = sPath & IIf(Right(sPath, 1) <> "\", "\", "")
End Function
Rem ==========
Private Sub ChangeKeys(ByRef strBinaryFile As Variant, ByRef isLockView As Boolean)
Dim F1 As Long, i As Long, lngCount As Long, bytTemp As Byte, strTemp As String * 5
Read_Binary:
F1 = FreeFile
Open strBinaryFile For Binary Access Read Write As #F1
Do
i = i + 1
Get #F1, i, bytTemp
If bytTemp = 67 Or bytTemp = 68 Or bytTemp = 71 Then
Get #F1, i, strTemp
If strTemp = "CMG=""" Or strTemp = "DPB=""" Or strTemp Like "GC=""*" Then
lngCount = lngCount + 1
If isLockView Then GoSub Change_Binary Else GoSub Clear_Binary
End If
End If
Loop While Not EOF(F1)
GoTo Finally
Clear_Binary:
For i = Loc(F1) - 4 To LOF(F1)
Get #F1, i, bytTemp
Put #F1, i, CByte(10) 'https://stackoverflow.com/questions/23590507
If bytTemp = 13 Then Exit For
Next
Return
Change_Binary:
For i = Loc(F1) + 1 To LOF(F1)
Get #F1, i, bytTemp
If bytTemp = 34 Then
Exit For
ElseIf bytTemp > 64 And bytTemp < 70 Then '{ABCDEF}\F
Put #F1, i, CByte(bytTemp + 1)
End If
Next
Return
Finally:
Close #F1
' If lngCount = 3 Or lngCount = 6 Then
' If strLanguage = "en" Then
' strMessage = "Wonderful!" & vbNewLine & vbNewLine & _
' "The source codes of your file is " & _
' IIf(isLockView, "lock.", "unlock.")
' Else
' strMessage = UnicodeVBA$("Tuyeejt vowfi !" & vbNewLine & vbNewLine & _
' "Max nguoofn taajp tin bajn yeeu caafu ddax dduwowjc " & _
' IIf(isLockView, "khosa.", "mowr."))
' End If
' isFinished = True
' Else
' If strLanguage = "en" Then
' strMessage = "Hmm, It is too embarrassing!" & vbNewLine & vbNewLine & _
' "Something went wrong so LabX can not finish your work."
' Else
' strMessage = UnicodeVBA$("Huwfm," & vbNewLine & vbNewLine & _
' "Cos ddieefu gif ddos sai sai neen LabX khoong theer " & _
' "hoafn thafnh coong vieejc cho bajn.")
' End If
' isFinished = False
' End If
End Sub
Rem ==========
Private Sub LockUnlockVBA(ByVal FileExcel As String, ByVal isLockView As Boolean)
Dim Fso As Object, ObjShell As Object, TempPath
Dim FileName_Path, ZipFile, vbaProject As String
Dim sPath As String, NewFile As String, OldFile As String
Dim strFileName, strFileType, strFileNote
Set ObjShell = CreateObject("Shell.Application")
Set Fso = CreateObject("Scripting.FileSystemObject")
If Fso.FileExists(FileExcel) = False Then Exit Sub
sPath = Fso.GetFile(FileExcel).ShortPath ''Lay ShortPath cua File
FileName_Path = FixPath(Fso.GetFile(sPath).ParentFolder) ''Lay ShortPath cua Folder .. xu ly loi khi Folder la Tieng Viet co dau
Rem === Khai bao Thong tin Su dung
TempPath = FixPath(Fso.GetSpecialFolder(2)) ''Lay Folder Rac
vbaProject = TempPath & "vbaProject.bin"
strFileName = Fso.GetBaseName(FileExcel)
strFileType = "." & Fso.GetExtensionName(FileExcel)
strFileNote = IIf(isLockView, "_Unviewable", "_Unlock")
NewFile = TempPath & strFileName & strFileNote & strFileType
OldFile = FileName_Path & strFileName & strFileNote & strFileType
ZipFile = NewFile & ".zip"
Rem === Xoa het File cu neu co
If Fso.FileExists(OldFile) Then Fso.DeleteFile (OldFile)
If Fso.FileExists(NewFile) Then Fso.DeleteFile (NewFile)
If Fso.FileExists(ZipFile) Then Fso.DeleteFile (ZipFile)
Rem === Copy File Moi
Fso.CopyFile FileExcel, NewFile, True
If Fso.FileExists(NewFile) Then
Fso.MoveFile NewFile, ZipFile
Rem Cut File vbaProject.bin Trong *.zip ra ngoai Folder
ObjShell.Namespace(TempPath).movehere ObjShell.Namespace(ZipFile).items.Item("xl\vbaProject.bin")
Do While ObjShell.Namespace(ZipFile & "\xl\") Is Nothing
Application.Wait (Now + 0.000005) ''Cho xu ly cho toi khi ket thuc sao 0.5 giay
Loop
Call LockUnlocProject(vbaProject, isLockView) ''Xu ly ma hoa chuoi trong File vbaProject.bin
Rem Cut File vbaProject.bin Vao File *.zip
ObjShell.Namespace(ZipFile & "\xl\").movehere ObjShell.Namespace(TempPath).items.Item("vbaProject.bin")
Do Until Not Fso.FileExists(vbaProject)
Application.Wait (Now + 0.000005)
Loop
Fso.MoveFile ZipFile, NewFile
Do Until Not Fso.FileExists(ZipFile)
Application.Wait (Now + 0.000002)
Loop
Fso.MoveFile NewFile, FileName_Path
MsgBox "done", 64, "Thông Báo"
End If
Set ObjShell = Nothing
Set Fso = Nothing
End Sub
Rem ==========
Sub Lock_vbaProject()
Dim vFile
vFile = Application.GetOpenFilename("All Files, *.xls; *.xlsx; *.xlsm; *.xlsb;*.xla; *.xlam")
''vFile = FilePicker()
If TypeName(vFile) = "String" Then Call LockUnlockVBA(vFile, True)
End Sub
Rem ==========
Sub UnLock_vbaProject()
Dim vFile
vFile = Application.GetOpenFilename("All Files, *.xls; *.xlsx; *.xlsm; *.xlsb;*.xla; *.xlam")
''vFile = FilePicker()
If TypeName(vFile) = "String" Then Call LockUnlockVBA(vFile, False)
End Sub
Rem ==========Thế bạn đã thử với file XLSB được khóa theo dạng Project Unview chưa? (không phải là khóa password VBA nha)
có lẻ vầy Anh nói một đường em nói 1 kiểu chi tiết vầy
Thì tôi đang nói đến vấn đề này đây!3/ Còn mở file dạng Project Unview do người khác khóa là .................. Tịt ........
khóa Module rồi sao không code thêm chút nữa mở luôn khóa Module vậy
Việc làm hiện lại được module đã ẩn cũng không phải là việc dễ dàng nhé :
Thử với File có Class Module xem điều gì sẻ đến ....
Ở đây là các module cơ bản bạn nhé, class (module) không ẩn được (sẽ bị lỗi).
Cập nhật phiên bản 1.1 :
Sao ứng dụng của bạn không có hiện Module vậy? Sao có thể kiểm tra bảo mật được?
Các bạn dùng addin này để tự kiểm tra bảo mật file excel của chính bạn nhé. Tôi không khuyến khích các bạn đi bẻ khóa phần mềm của người khác.
Vấn đề này dựa trên uy tín cá nhân tôi. Bạn nào tin thì dùng, không tin thì thôi.
github.com
program excel_sheet_unprotect;
{$APPTYPE CONSOLE}
uses
SysUtils, ComObj, ActiveX, Windows, Dialogs,
Messages, Variants, Classes, Graphics, Controls, Forms,
StdCtrls;
function unprotectSheet(P : Variant): boolean;
var i, j, k, l, m, i1, i2, i3, i4, i5, i6, n : integer;
begin
result := true;
For i := 65 To 66 do
For j := 65 To 66 do
For k := 65 To 66 do
For l := 65 To 66 do
For m := 65 To 66 do
For i1 := 65 To 66 do
For i2 := 65 To 66 do
For i3 := 65 To 66 do
For i4 := 65 To 66 do
For i5 := 65 To 66 do
For i6 := 65 To 66 do
For n := 32 To 126 do
begin
if P.ProtectContents then
try
P.Unprotect(Chr(i) + Chr(j) + Chr(k) + Chr(l) + Chr(m) + Chr (i1) + Chr(i2) + Chr(i3) + Chr(i4) + Chr(i5) + Chr(i6) + Chr(n));
writeln(#13#10'Here is your password:');
writeln(Chr(i) + Chr(j) + Chr(k) + Chr(l) + Chr(m) + Chr (i1) + Chr(i2) + Chr(i3) + Chr(i4) + Chr(i5) + Chr(i6) + Chr(n));
except
end
else
exit;
end;
writeln(#13#10'Operation terminated unsuccessfully');
result := false;
end;
var
VExcel, VWB, VWS, vip: OleVariant;
dialog : TOpenDialog;
s: string;
begin
dialog := TOpenDialog.Create(nil);
writeln('Enter Excel file');
if not dialog.Execute then
exit;
CoInitialize(nil);
try
VWB := CreateOleObject('Excel.Application');
except
writeln(#13#10'Cannot initiate Excel');
Exit;
end;
VWB.DisplayAlerts := False;
VWB.Visible := False;
VWB.WorkBooks.open(dialog.filename);
VExcel := VWB.Application;
//VWS := VWB.Workbooks[1].WorkSheets[1]; //MANH BỎ
VWS := VWB.Workbooks[1]; //THAY DONG TRÊN
writeln(#13#10'Working...');
if VWS.ProtectContents then
unprotectSheet(VWS)
else writeln(#13#10'Sheet is not locked.');
// Uncomment one of the lines bellow if you want to save the unprotected file
//VWB.Workbooks[1].Save;
//VWB.Workbooks[1].SaveAs (dialog.filename+' new');
// Closing Excel...
VWS := Unassigned;
VWB := Unassigned;
VExcel.Workbooks.Close;
VExcel.Quit;
VExcel := Unassigned;
writeln(#13#10'Press Enter to Exit');
s:=#0;
while(s=#0) do
readln(s);
end.Thì cái link đầu cái nó chỉ cách chữ to và đậm đó ... chịu khó coi đi xong viết lại cái Hàm sau thêm Tùy chọn xử lý nó
Public Sub HideModules(ByRef strBinaryFile As String)
Dim F1 As Long, i As Long, lngCount As Long
Dim bytTemp As Byte, strTemp As String * 7
Dim objFiSystem As Object, strShortPath As String
Set objFiSystem = CreateObject("Scripting.FileSystemObject")
strShortPath = objFiSystem.GetFile(strBinaryFile).ShortPath
Set objFiSystem = Nothing
Read_Binary:
F1 = FreeFile
Open strShortPath For Binary Access Read Write As #F1
Do
i = i + 1
Get #F1, i, bytTemp
If bytTemp = 77 Then '4D
Get #F1, i, strTemp
If strTemp = "Module=" Then
lngCount = lngCount + 1
For i = Loc(F1) - 6 To LOF(F1)
Get #F1, i, bytTemp
Put #F1, i, CByte(10) '0A
If bytTemp = 13 Then Exit For '0D
Next
End If
End If
Loop While Not EOF(F1)
Finally:
Close #F1
' If lngCount > 0 Then
' If strLanguage = "en" Then
' strMessage = "Wonderful!" & vbNewLine & vbNewLine & _
' "All modules of your excel file are hide."
' Else
' strMessage = UnicodeVBA$("Tuyeejt vowfi !" & vbNewLine & vbNewLine & _
' "Taast car module trong taajp tin bajn yeeu caafu ddax dduwowjc aarn.")
' End If
' isFinished = True
' Else
' If strLanguage = "en" Then
' strMessage = "Hmm, It is too embarrassing!" & vbNewLine & vbNewLine & _
' "Something went wrong so LabX can not finish your work."
' Else
' strMessage = UnicodeVBA$("Huwfm," & vbNewLine & vbNewLine & _
' "Cos ddieefu gif ddos sai sai neen LabX khoong theer " & _
' "hoafn thafnh coong vieejc cho bajn.")
' End If
' isFinished = False
' End If
End SubBác share e cái hướng dẫn ẩn các Hàm trong Object Browser với. Cái này e chưa biết
