ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 127|回复: 1

哪位高手能确认被隐藏的模块与窗体

[复制链接]

TA的精华主题

TA的得分主题

发表于 2024-10-13 10:22 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 OFFPRO 于 2024-10-13 16:29 编辑

本工具本身有保护VBA代码功能,有英日文两种语言格式为xlam,在国外知名网站下载,但是模块窗体被隐藏,哪位高手能确认被隐藏的模块与窗体。

*难度较大,已删除附件,谢谢!

pic

pic

TA的精华主题

TA的得分主题

 楼主| 发表于 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



20241013115205.png
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-1 10:22 , Processed in 0.027671 second(s), 8 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表