|
楼主 |
发表于 2024-10-13 10:53
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
本帖最后由 OFFPRO 于 2024-10-13 16:30 编辑
用论坛内工具初步解密只能查看到一小部分代码与一个空白窗体。
*初步判明使用了混淆dumy代码方法
Thisworkbook内容
----------------------
Option Explicit
Private Sub Workbook_Open()
Call WO
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call WBC
End Sub
模块1内容
----------------------
Option Explicit
Option Private Module
Option Base 1
#If Win64 Then
Private Declare PtrSafe Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
#Else
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
#End If
Sub WO()
Dim NewBook As String
Dim W_MSG As String
Dim FSO As Object
If ADV_CHK = False Then
W_MSG = "To open, enable ""Trust access to the VBA project object model"" in the Trust Center."
MsgBox W_MSG
Exit Sub
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
ThisWorkbook.Worksheets(1).OLEObjects(1).Verb xlVerbOpen
Set FSO = CreateObject("Scripting.FileSystemObject")
NewBook = FSO.GetSpecialFolder(2) & "\" & Workbooks(Workbooks.Count).Name & ".xlam"
Set FSO = Nothing
ThisWorkbook.Worksheets(1).Cells(1, 1).Value = NewBook
On Error Resume Next
Application.VBE.CommandBars(1).Controls(6).Controls(1).Execute
On Error GoTo 0
Application.Wait Now
DoEvents
Application.DisplayAlerts = False
Workbooks(Workbooks.Count).SaveAs NewBook, xlOpenXMLAddIn
Application.DisplayAlerts = True
Workbooks(Workbooks.Count).Close False
Call OMAIN_XL(NewBook)
Application.EnableEvents = True
Application.ScreenUpdating = True
Workbooks.Open NewBook
End Sub
Private Sub OMAIN_XL(ByVal W_INF As String)
Dim W_OTF As String
Dim FSO As Object
Dim W_DIR As String
Dim W_BAS As String
Dim W_EXT As String
Dim W_ZIP As String
Dim W_TMP As String
Dim W_ZDIR As String
Dim W_VBA As String
Dim WB As Workbook
Dim W_RET As Long
Dim W_MSG As String
Set FSO = CreateObject("Scripting.FileSystemObject")
W_DIR = FSO.GetParentFolderName(W_INF)
W_EXT = FSO.GetExtensionName(W_INF)
W_BAS = FSO.GetBaseName(W_INF)
Set FSO = Nothing
W_OTF = W_DIR & "\" & W_BAS & "_Opt." & W_EXT
Set FSO = CreateObject("Scripting.FileSystemObject")
W_TMP = FSO.GetSpecialFolder(2)
W_ZIP = W_TMP & "\" & W_BAS & ".zip"
CopyFile W_INF, W_ZIP, 0
W_ZDIR = W_TMP & "\" & RTrim$(W_BAS)
If UNZIP(W_ZIP, W_ZDIR) = False Then
W_MSG = "Open Failed."
MsgBox W_MSG
Exit Sub
End If
W_VBA = VBA_SRCH(W_ZDIR)
If RE_BIN(W_VBA, False) = False Then
W_MSG = "Open Failed."
MsgBox W_MSG
Exit Sub
End If
Call ZIP(W_ZDIR, W_ZIP)
CopyFile W_ZIP, W_INF, 0
On Error Resume Next
Kill W_ZIP
On Error GoTo 0
End Sub
Private Function RE_BIN(ByVal W_INF As String, ByVal SW_REV As Boolean) As Boolean
Dim AR_BYTE() As Byte
Dim B As Long
Dim B2 As Long
Dim FSO As Object
Dim W_STR As String
Dim I As Long
Dim SW_EXE As Boolean
RE_BIN = True
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(W_INF) = False Then
Set FSO = Nothing
RE_BIN = False
Exit Function
End If
Set FSO = Nothing
ReDim AR_BYTE(FileLen(W_INF))
Open W_INF For Binary As #1
Get #1, , AR_BYTE
Close #1
SW_EXE = False
For B = UBound(AR_BYTE) - 10 To 1 Step -1
If AR_BYTE(B) = &HA And AR_BYTE(B + 1) = &H44 And AR_BYTE(B + 2) = &H6F And AR_BYTE(B + 3) = &H63 And AR_BYTE(B + 4) = &H75 And AR_BYTE(B + 5) = &H6D And AR_BYTE(B + 6) = &H65 And AR_BYTE(B + 7) = &H6E And AR_BYTE(B + 8) = &H74 And AR_BYTE(B + 9) = &H3D Then
W_STR = ""
For I = B + 10 To UBound(AR_BYTE)
If AR_BYTE(I) = &H2F Then
Exit For
End If
If AR_BYTE(I) >= 0 And AR_BYTE(I) <= 128 Then
W_STR = W_STR & Chr$(AR_BYTE(I))
Else
W_STR = W_STR & Chr$(CLng(AR_BYTE(I)) * 256 + CLng(AR_BYTE(I + 1)))
I = I + 1
End If
Next I
If W_STR = "Sheet1" Then
AR_BYTE(I - 1) = &H40
SW_EXE = True
Exit For
End If
End If
Next B
If SW_EXE = False Then
RE_BIN = False
Exit Function
End If
Open W_INF For Binary As #1
Put #1, , AR_BYTE
Close #1
End Function
Private Function VBA_SRCH(ByVal W_ZDIR As String) As String
Dim W_XML As String
Dim ADS As Object
Dim W_STR As String
Dim RE As Object
VBA_SRCH = ""
W_XML = W_ZDIR & "\[Content_Types].xml"
Set ADS = CreateObject("ADODB.Stream")
ADS.Open
ADS.Charset = "UTF-8"
ADS.LineSeparator = -1
ADS.LoadFromFile W_XML
W_STR = ADS.ReadText
ADS.Close
Set ADS = Nothing
If InStr(W_STR, "application/vnd.ms-office.vbaProject") = 0 Then
VBA_SRCH = W_ZDIR & "\xl\vbaProject.bin"
Else
Set RE = CreateObject("VBScript.RegExp")
RE.IgnoreCase = True
RE.Global = True
RE.Pattern = "<Override PartName=""([^""]*?)"" ContentType=""application/vnd.ms-office.vbaProject""/>"
If RE.Test(W_STR) = True Then
VBA_SRCH = W_ZDIR & RE.Execute(W_STR)(0).Submatches(0)
End If
Set RE = Nothing
End If
End Function
Function UNZIP(ByVal W_FROM As String, ByVal W_TO As String) As Boolean
Dim FSO As Object
Dim SA As Object
Dim FILE As Object
Dim DEST As Object
UNZIP = True
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(W_TO) Then
FSO.DeleteFolder W_TO, True
End If
Do While FSO.FolderExists(W_TO)
DoEvents
Loop
FSO.CreateFolder W_TO
Set FSO = Nothing
Set SA = CreateObject("Shell.Application")
Set FILE = SA.Namespace(CVar(W_FROM))
Set DEST = SA.Namespace(CVar(W_TO & "\"))
DEST.CopyHere FILE.Items, 1028
If DEST.Items().Count = 0 Then
UNZIP = False
End If
Set FILE = Nothing
Set DEST = Nothing
Set SA = Nothing
On Error Resume Next
Kill W_FROM
On Error GoTo 0
End Function
Sub ZIP(ByVal W_FROM As String, ByVal W_TO As String)
Dim CL As Collection
Dim FSO As Object
Dim CTF As Object
Dim FL As Variant
Dim SW_1ST As Boolean
Dim W_COM As String
Dim W_PATH As String
Dim W_TMP As String
Dim W_BUF As String
Dim WSS As Object
On Error Resume Next
Kill W_TO
On Error GoTo 0
Set CL = New Collection
Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO.GetFolder(W_FROM)
For Each FL In .SubFolders
CL.Add W_FROM & "\" & FL.Name
Next
For Each FL In .Files
CL.Add W_FROM & "\" & FL.Name
Next
End With
W_COM = "Compress-Archive -Path"
SW_1ST = True
For Each FL In CL
If SW_1ST = True Then
W_PATH = """" & FL & """"
SW_1ST = False
Else
W_PATH = W_PATH & ",""" & FL & """"
End If
Next
W_PATH = Replace(W_PATH, "[", "``[")
W_PATH = Replace(W_PATH, "]", "``]")
W_COM = W_COM & " " & W_PATH & " -DestinationPath """ & W_TO & """ -Force"
W_TMP = FSO.GetSpecialFolder(2) & "\PSCOM.ps1"
Set CTF = FSO.CreateTextFile(W_TMP, True)
CTF.Write W_COM
CTF.Close
Set CTF = Nothing
W_BUF = "powershell -ExecutionPolicy RemoteSigned -File """ & W_TMP & """"
Set WSS = CreateObject("WScript.Shell")
WSS.Run W_BUF, 0, True
Set WSS = Nothing
FSO.DeleteFile W_TMP
If FSO.FolderExists(W_FROM) Then
FSO.DeleteFolder W_FROM, True
End If
Set FSO = Nothing
End Sub
Sub WBC()
Dim NewBook As String
NewBook = ThisWorkbook.Worksheets(1).Cells(1, 1).Value
On Error Resume Next
Kill NewBook
On Error GoTo 0
End Sub
Function ADV_CHK() As Boolean
Dim W_VER As String
W_VER = ""
On Error Resume Next
W_VER = Application.VBE.Version
On Error GoTo 0
If W_VER <> "" Then
ADV_CHK = True
End If
End Function
|
-
|