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 ==========
