Malicious Office (OOXML) — malware analysis report

Static analysis result for SHA-256 119e8d391f8062ea…

MALICIOUS

Office (OOXML)

105.2 KB Created: 2017-09-22 01:14:00 UTC Authoring application: Microsoft Excel First seen: 2021-10-24
MD5: f80b9128b23aa8c8b9ed66aa808599b9 SHA-1: 3e4e540583d7e94ccf42ae724c9229befa5f6d11 SHA-256: 119e8d391f8062ea94b4f7d00c149fd31d2aabbef7aea2871a80ace9332e129c
302 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1204.002 Malicious File T1566.001 Spearphishing Attachment

The sample contains VBA macros that utilize WScript.Shell and CreateObject to execute commands and potentially download or upload files. The embedded URL `http://hk.r34.cc/index.php/Qwadmin/Rwxy/echoteacherdbnep?conall=%E6%95%B0%E6%8D%AE%E8%A1%A8%E5%90%8D%E7%AD%89%E4%BA%8E%E7%8E%8B%E8%BF%9B%E5%88%A9%E6%96%87%E4%BB%B6%E7%AE%A1%E7%90%86IJ%3B%E6%9F%A5%E7%9C%8B%E5%AF%86%E7%A0%81%E7%AD%89%E4%BA%8Eadmin%3B` and other related URLs suggest a credential harvesting or data exfiltration attempt. The document body's tabular structure and prompts for passwords and usernames further support this. The VBA script's use of `Shell()` and `WScript.Shell` indicates it is designed to execute arbitrary commands, likely to facilitate the malicious objective.

Heuristics 8

  • VBA project inside OOXML medium 4 related findings OOXML_VBA
    Document contains a VBA project — VBA macros present
  • Potential Shell call in VBA critical OLE_VBA_SHELL
    Potential Shell call in VBA
    Matched line in script
            If IsFileExists(notepad2url) = True Then
            aa = Shell(notepad2url & " " & TEMPJSON, vbNormalFocus)
        End If
  • WScript.Shell usage critical OLE_VBA_WSCRIPT
    WScript.Shell usage
    Matched line in script
    Dim wsh
Set wsh = CreateObject("WScript.Shell")
tempfile = TEMPMDFILE
  • LOLBin reference in VBA critical OLE_VBA_LOLBIN
    LOLBin reference in VBA
    Matched line in script
        If VBA.Mid(url, Len(url) - 2, 3) = "vbs" Then
        WshShell.Run "wscript.exe " & url, 2, True
    ElseIf VBA.Mid(url, Len(url) - 2, 3) = "bat" Then
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
    ConSName = ActiveSheet.Name & PZNAME
Set fso = CreateObject("scripting.filesystemobject")
Dim weburl, content As String
  • Suspicious extracted artifact high EXTRACTED_FILE_STATIC_TRIAGE
    One or more files extracted from inside this sample matched static suspicious-content checks such as script obfuscation, encoded payload blobs, packed data, or execution/download terms.
  • External relationship medium OOXML_EXTERNAL_REL
    External target in xl/externalLinks/_rels/externalLink1.xml.rels: 数据第一行开始2.xlsm
  • Embedded URL info EMBEDDED_URL
    One or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.
    URL http://hk.r34.cc/index.php/Qwadmin/Rwxy/echoteacherdbnep?conall=%E6%95%B0%E6%8D%AE%E8%A1%A8%E5%90%8D%E7%AD%89%E4%BA%8E%E7%8E%8B%E8%BF%9B%E5%88%A9%E6%96%87%E4%BB%B6%E7%AE%A1%E7%90%86IJ%3B%E6%9F%A5%E7%9C%8B%E5%AF%86%E7%A0%81%E7%AD%89%E4%BA%8Eadmin%3B OOXML external relationship

Extracted artifacts 2

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source from OOXML) 53164 bytes
SHA-256: 43226d645a243e4d9b0397a947232be3fee9b864e15403cc02b80c85a960129f
Detection
ClamAV: No threats found
Obfuscation or payload: likely
Carved artifact contains 3 eval/decoder/string-building token(s).
Preview script
First 1,000 lines of the extracted script
Attribute VB_Name = "模块1"
Public Const STARTROW As Integer = 1      '声明一个公共常量
Public Const startcell As String = "A1"  '起始单元格
Public Const conrow As Integer = 17      '条件个数
Public Const conmaxline As Integer = conrow    '条件个数
Public Const softfolder As String = "\基础软件\"      '声明一个公共常量
Public Const downurl As String = "/index.php/Qwadmin/Rwxy/echoteacherdbnep?"      '下载的地址串
Public Const downurlcom As String = "/index.php/Qwadmin/RwxyCom/echoteacherdbnep?"      '下载的地址串Com
Public Const upurl As String = "/index.php/Qwadmin/Rwxy/phpupload?" '上传的地址串
Public Const upurlcom As String = "/index.php/Qwadmin/RwxyCom/phpupload?" '上传的地址串Com
Public Const uponefileurlcom As String = "/index.php/Qwadmin/RwxyCom/phpuploadonefile" '上传的地址串Com
Public Const uponefileurl As String = "/index.php/Qwadmin/Rwxy/phpuploadonefile" '上传的地址串"

'这里有两套写法，如果要改，都一起改
Public Const rpwcell As String = "F1"  '查看密码列
Public Const wrpwcell As String = "F2" '上传密码列
Public Const sheetnamecell As String = "C1"  '数据表所在列


'密码区
Public Const website As String = "F5"  '网站网址
Public Const siteuer As String = "F3"  '网站的用户名
Public Const sitepassword As String = "F4"  '网站的密码

'本地参数
Public Const downurldebugcell As String = "M1" '下载字符串生成
Public Const delpasswordcell As String = "M8"  '自动清空上传密码、用户密码
Public Const cellsheetnname As String = "M3"  '复制到新的数据表的名字
Public Const cellplace As String = "M4"  '复制到新的位置的单元格位置
Public Const cellautodownloadfile As String = "M5"  '是否自动下载文件，一般建议否
Public Const cellfilenamecol As String = "M6"  '文件名规则所在的单元格    文件名及文件夹的命名方式变更要全删了
Public Const cellfoldercol As String = "M7"  '文件名规则所在的单元格      文件名及文件夹的命名方式变更要全删了
Public Const FileChar As String = "文件"  '文件上传的标志符
Public Const SepChar As String = "_"  '文件上传的标志符
Public Const popupdatecell As String = "M2"  '覆盖提示



'真正的常量
Public Const FILESAVEPATHCELL   As String = "M9"      '声明一个公共常量
Public Const download1 As String = "B"  '下载的第一列文件
Public Const download1filename As String = "A"  '第一列文件对应的文件名
Public Const ZDYCHAR As String = "自定义"  '自定义文件名
Public Const GLWY As String = "_管理网页.html"  '管理网页名称
Public Const TEMPTXTFILE   As String = "D:\老黄牛小工具\ExcelQuery\temp\temp.txt"      '临时文件路径
Public Const TEMPMDFILE   As String = "D:\老黄牛小工具\ExcelQuery\temp\md.md"      '临时md文件路径
Public Const TEMPMDIMG   As String = "D:\老黄牛小工具\ExcelQuery\temp\temp.jpg"      '临时jpg文件路径
Public Const CURLPATH   As String = "D:\老黄牛小工具\ExcelQuery"     'curl.exe
Public Const PZNAME As String = "配置" '上传的地址串"
Public Const FZFLOLDER As String = "基础软件" '辅助文件夹




'------------------------上传下载模块---------------------------------------


'------------------------文件上传---------------------------------------


'点击单元格的数据
Sub 点击单元格的数据()
ConSName = ActiveSheet.Name & PZNAME
Set fso = CreateObject("scripting.filesystemobject")
Dim weburl, content As String
i = ActiveCell.row
S = ActiveCell.Column
content = Cells(i, S)


                ext = fso.GetExtensionName(content)
                filename = renamefilename(i, S)
                savePath = ThisWorkbook.Path & Mkcelldir2nodel(i, S)
                savename = filename & "." & ext
                NewFile = Replace(savePath & "\" & savename, "\\", "\")

 

If IsFileExists(content) Then  ' 如果文件存在，刚直接打开
    ActiveWorkbook.FollowHyperlink content

ElseIf Mid(content, 1, 1) = "\" Then
    If IsFileExists(NewFile) Then
        ActiveWorkbook.FollowHyperlink NewFile
    End If
    
ElseIf isurl(content) Then
    If IsFileExists(NewFile) And filename <> "" Then
        ActiveWorkbook.FollowHyperlink NewFile
    Else
        If Mid(content, 1, 4) = "http" Then
            weburl = content
        Else
             weburl = Sheets(ConSName).Range(website).Value & content
        End If
        ActiveWorkbook.FollowHyperlink weburl
    End If
Else
    ActiveWorkbook.FollowHyperlink savePath
End If





End Sub



'重命名文件
Function renamefilename(ByVal i As Integer, ByVal S As Integer, Optional ofilename As String = "")
ConSName = ActiveSheet.Name & PZNAME
  Dim a As Variant
   Dim b As Variant
   Dim ddd As String
Dim fileexplain As String

'查找对应的说明,标题行中的文件名称
fileexplain = Cells(STARTROW, S).Value
fileexplain = Replace(fileexplain, FileChar, "")

If InStr(fileexplain, ZDYCHAR) Then
    Set fso = CreateObject("Scripting.FileSystemObject")
    t0 = Cells(i, S).Value
    If t0 = "" Then
        fileexplain = ofilename
    Else
        fileexplain = fso.GetBaseName(t0)
    End If
End If

Debug.Print (fileexplain)
    ddd = Sheets(ConSName).Range(cellfilenamecol).Value
   If ddd = "" Then
    ddd = "" '文件命名为空，那么就本地不保存了
    renamefilename = ""
   Else
       a = Split(ddd, ",")
       b = UBound(a)
    
       filename = ""
       For j = 0 To b
    
       
        If j < b Then
          renamefilename = renamefilename & Range(a(j) & i).Value & SepChar
        Else
          renamefilename = renamefilename & Range(a(j) & i).Value
        End If
       Next
    renamefilename = renamefilename & SepChar & fileexplain
    renamefilename = Replace(renamefilename, SepChar & SepChar, SepChar)
   End If



'MsgBox (renamefilename)


End Function

Sub 备份第一行的样式()
    ActsheetName = ActiveSheet.Name
    Rows("1:1").Select
    Selection.Copy
    Sheets("生成表").Select
    Rows("1:1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
 Sheets(ActsheetName).Select
End Sub

Sub 还原第一行的样式()
ActsheetName = ActiveSheet.Name

    Sheets("生成表").Select
    Rows("1:1").Select
    Selection.Copy
    Sheets(ActsheetName).Select
    Rows("1:1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
End Sub




'表格上传文件
Sub 传参表格上传文件()
MsgBox ("移动上传提示2")
Call 表格上传文件公共区("表格移动文件", filepath)
End Sub
'表格网络上传文件
Sub 表格网络上传文件()
Dim filepath As String
filepath = txt_read(TEMPTXTFILE)
Call 表格上传文件公共区("表格网络上传文件", filepath)
End Sub

'表格上传文件
Sub 表格上传文件()
Dim filepath As String
filepath = txt_read(TEMPTXTFILE)
Call 表格上传文件公共区("表格上传文件", filepath)
End Sub


'表格移动文件
Sub 表格移动文件()
Dim filepath As String
filepath = txt_read(TEMPTXTFILE)
Call 表格上传文件公共区("表格移动文件", filepath)
End Sub



'弹窗表格网络上传文件
Sub 弹窗表格网络上传文件(Optional filepath As String = "")

Dim first2char
nowrow = Selection.row()
nowColumn = Selection.Column()
first2char = Mid(Cells(STARTROW, nowColumn), 1, 2)
    If first2char = "文件" Or first2char = "照片" Then
            'filepath = GetFilePathFromDialog()
            Call 表格上传文件公共区("表格网络上传文件", filepath)
    Else
        MsgBox ("请选中，文件列！~")
    End If
    

End Sub


Sub 表格上传文件公共区(Optional uploadtype As String = "", Optional filepath As String = "")
ConSName = ActiveSheet.Name & PZNAME
Set fso = CreateObject("scripting.filesystemobject")
savePath = ThisWorkbook.Path & "\" & Sheets(ConSName).Range(FILESAVEPATHCELL) & "\"
Call lilyMkDir(CStr(savePath))

ff = ActiveSheet.Range(sheetnamecell).Value
'bb = GetFilePathFromDialog()
nowrow = Selection.row()
nowColumn = Selection.Column()

'MsgBox (nowrow & "-" & nowColumn)


first2char = Mid(Cells(STARTROW, nowColumn), 1, 2)
            If first2char = "文件" Or first2char = "照片" Then
                If filepath = "" Then
                    filepath = GetFilePathFromDialog()
                End If
                
                'Debug.Print (filepath)
                    ext = fso.GetExtensionName(filepath)
                    filename = renamefilename(nowrow, nowColumn)
                    savePath = Mkcelldir(nowrow, nowColumn)
                    savename = filename & "." & ext
                    
                    NewFile = Replace(savePath & "\" & savename, "\\", "\")
                    '文件已存在的话，自动加个数字
                    'savename = renamebyaddnum(filename, ext, savePath)
'MsgBox (nowrow & "-" & nowColumn & "2222")
             
                    '有数据提示
                    If Cells(nowrow, nowColumn).Value <> "" Then
                        result = MsgBox("选中单元格中已有数据，是否覆盖？", 3, "通用查询系统")
                    End If
                    If result = 6 Or Cells(nowrow, nowColumn).Value = "" Then

                         If filepath <> "" Then
                            If uploadtype = "表格上传文件" Then
                                '表格本地上传文件
                                If filename <> "" Then
                                    fso.CopyFile filepath, NewFile
                                    Cells(nowrow, nowColumn).Value = Mkcelldir2nodel(nowrow, nowColumn) & savename
                                End If
                            ElseIf uploadtype = "表格网络上传文件" Then
                                '表格本地上传文件
                                If filename <> "" Then
                                    fso.CopyFile filepath, NewFile
                                End If
                                
                                If Sheets(ConSName).Range(website) <> "" Then
                                    
                                    Cells(nowrow, nowColumn).Value = returnurl
                                Else
                                    Cells(nowrow, nowColumn).Value = Mkcelldir2nodel(nowrow, nowColumn) & savename
                                End If
                            ElseIf uploadtype = "表格移动文件" Then
                                '表格本地移动文件
                                If filename <> "" Then
                                    lilymovefile filepath, NewFile
                                    Cells(nowrow, nowColumn).Value = Mkcelldir2nodel(nowrow, nowColumn) & savename
                                End If
                                
                            Else
                                '不执行
                            
                            End If
                        End If
                    Else
                        End
                    End If
                    '返回地址
                    
            Else
                MsgBox ("请选中，文件列！~")
            End If



End Sub



'编辑单元格
Sub 编辑单元格()
Dim wsh
Set wsh = CreateObject("WScript.Shell")
tempfile = TEMPMDFILE
ConSName = ActiveSheet.Name & PZNAME
Set fso = CreateObject("scripting.filesystemobject")
savePath = ThisWorkbook.Path & "\" & Sheets(ConSName).Range(FILESAVEPATHCELL) & "\"
Call lilyMkDir(CStr(savePath))

ff = ActiveSheet.Range(sheetnamecell).Value
'bb = GetFilePathFromDialog()
nowrow = Selection.row()
nowColumn = Selection.Column()
ee = ActiveSheet.Cells(nowrow, nowColumn).Value
'MsgBox (ee)




    mdexe = getcurlpath("MarkdownEditor.exe")
    


Call Writefile(tempfile, ee, "utf-8")
    '用notepad2.exe打开刚生成的文件
    If IsFileExists(tempfile) = True Then
           '用notepad2.exe打开刚生成的文件
        If IsFileExists(mdexe) = True Then
            '''''''''''''''''''''''''aa = wsh.Ru2n__temp(mdexe & " " & tempfile, 0, True)        这里强行注释，使之不报毒
        End If
        '22She2ll temp2file
    End If
'MsgBox ("测试")


FileContent = readfile(tempfile, "utf-8")


Cells(nowrow, nowColumn).Value = FileContent
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = True
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

'MsgBox (s1)
End Sub





Public Function GetFilePathFromDialog()
        With Application.FileDialog(msoFileDialogFilePicker)
            .AllowMultiSelect = False    '不允许多选
            .Filters.Clear                    '清除过滤器
            .Filters.Add "All Files", "*.*"
            If .Show = -1 Then                                     'Show 方法显示对话框，并且返回 -1（如果您按 OK）和 0（如果您按 Cancel）
                GetFilePathFromDialog = .SelectedItems(1)
            Else    '说明用户按了"取消"按钮，则提示程序将退出.
                GetFilePathFromDialog = ""
            End If
        End With

End Function


'重命名文件
Function Mkcelldir(ByVal i As Integer, ByVal S As Integer)
ConSName = ActiveSheet.Name & PZNAME
  Dim a As Variant
   Dim b As Variant
   Dim ddd As String
Dim fileexplain As String
Dim savePath As String
Dim v As String
        '保证下载目录的存在，并保证没有文件
        Set fso = CreateObject("scripting.filesystemobject")
        savePath = ThisWorkbook.Path & "\" & Sheets(ConSName).Range(FILESAVEPATHCELL) & "\"

    ddd = Sheets(ConSName).Range(cellfoldercol).Value
   If ddd = "" Then
        Mkcelldir = savePath
        ' Debug.Print (savePath)
   Else
       a = Split(ddd, ",")
       b = UBound(a)
      If b = 0 Then
      v = Trim(spit_val(i, S, a(j)))
     'Debug.Print (v)
        savePath = savePath + "\" + v
      Else
      
       For j = 0 To b
          v = Trim(spit_val(i, S, a(j)))
          savePath = savePath + "\" + v
       Next
      End If
        
        
    'Debug.Print (savePath)
       Call MultiMakeDir(savePath)
       Mkcelldir = savePath
   
   End If





'MsgBox (renamefilename)


End Function


'重命名文件夹并保证存在
Function Mkcelldir2nodel(ByVal i As Integer, ByVal S As Integer)
ConSName = ActiveSheet.Name & PZNAME
  Dim a As Variant
   Dim b As Variant
   Dim ddd As String
Dim fileexplain As String
Dim savePath As String
Dim v As String
        '保证下载目录的存在，并保证没有文件
        Set fso = CreateObject("scripting.filesystemobject")
        savePath = ThisWorkbook.Path
        Call lilyMkDir(CStr(savePath))
        RelativePathname = "\" & Sheets(ConSName).Range(FILESAVEPATHCELL) & "\"

    ddd = Sheets(ConSName).Range(cellfoldercol).Value
   If ddd = "" Then
        Mkcelldir2nodel = RelativePathname
        ' Debug.Print (savePath)
   Else
       a = Split(ddd, ",")
       b = UBound(a)
      If b = 0 Then
      v = Trim(spit_val(i, S, a(j)))
     'Debug.Print (v)
        RelativePathname = RelativePathname + "\" + v
      Else
      
       For j = 0 To b
          v = Trim(spit_val(i, S, a(j)))
          RelativePathname = RelativePathname + "\" + v
       Next
      End If
        
        
    'Debug.Print (savePath)
       Call MultiMakeDir(ThisWorkbook.Path & "\" & RelativePathname)
       Mkcelldir2nodel = RelativePathname
   
   End If





'MsgBox (renamefilename)


End Function
'重命名--文件夹名
Function spit_val(ByVal i As Integer, ByVal S As Integer, ByVal v As String)
       a = Split(v, "-")
       b = UBound(a)
      If b = 0 Then
        spit_val = Trim(Range(v & i).Value)
      Else
      
       For j = 0 To b
        spit_val = spit_val & "_" & Trim(Range(a(j) & i).Value)
        If Mid(spit_val, 1, 1) = "_" Then
            spit_val = Mid(spit_val, 2, Len(spit_val) - 1)
        End If
       Next
      End If


End Function


'剪贴文件
Function lilymovefile(ByVal filepath As String, ByVal newfilepath As String)
Set fso = CreateObject("scripting.filesystemobject")
If fso.FileExists(newfilepath) Then
fso.DeleteFile newfilepath, True
End If
fso.MoveFile filepath, newfilepath


End Function


Public Sub MultiMakeDir(Path As String)

   On Error Resume Next
    Dim o_strRet As String
    Dim o_intItems As Integer
    Dim o_vntItem As Variant
    Dim o_strItems() As String
    o_strItems() = Split(Path, "\")
    o_intItems = 0
    For Each o_vntItem In o_strItems()
        o_intItems = o_intItems + 1
        If o_intItems = 1 Then
            o_strRet = o_vntItem
        Else
            o_strRet = o_strRet & "\" & o_vntItem
            MkDir o_strRet
        End If
    Next
End Sub

' 判断文件是否存在了，存在后面加个1
Function renamebyaddnum(ByVal savename As String, ByVal ext As String, ByVal savePath As String)
Dim n
n = 0
'Debug.Print (Replace(savePath & "\" & savename, "\\", "\") & "." & ext)
If IsFileExists(savePath & "\" & savename & "." & ext) = False Then
    renamebyaddnum = savename & "." & ext
    Exit Function
End If
For n = 2 To 99
    If IsFileExists(savePath & "\" & savename & "-" & n & "." & ext) = False Then
        renamebyaddnum = savename & "-" & n & "." & ext
        Exit Function
    End If
Next
renamebyaddnum = "error" & "." & ext

End Function




'判断文件是否存在
Function IsFileExists(ByVal strFileName As String) As Boolean
    If Dir(strFileName, 16) <> Empty Then
        IsFileExists = True
    Else
        IsFileExists = False
    End If
End Function
'判断文件夹是否存在
Function IsFolderExists(folderpath As String) As Boolean
On Error GoTo EarlyExit
If Not Dir(folderpath, vbDirectory) = vbNullString Then
IsFolderExists = True
End If
Exit Function
EarlyExit:
IsFolderExists = False
End Function
'保证文件夹的存在
Sub lilyMkDir(folderpath As String)
If IsFolderExists(folderpath) Then
    '不执行
Else
    MkDir (folderpath)
End If

End Sub

Function CreateFolders(Path)
    Set fso = CreateObject("scripting.filesystemobject")
    CreateFolderEx fso, Path
    Set fso = Nothing
End Function
 
Function CreateFolderEx(fso, Path)
    If fso.FolderExists(Path) Then
        Exit Function
    End If
    If Not fso.FolderExists(fso.GetParentFolderName(Path)) Then
        CreateFolderEx fso, fso.GetParentFolderName(Path)
    End If
    fso.CreateFolder (Path)
End Function



Function getmaxroworcol()
ConSName = ActiveSheet.Name & PZNAME
endrowA = Range("A65000").End(xlUp).row
endrowB = Range("B65000").End(xlUp).row
endrowE = Range("E65000").End(xlUp).row
endrowF = Range("F65000").End(xlUp).row
endcol1 = ActiveSheet.[IV1].End(xlToLeft).Column
endrow = Application.Max(endrowA, endrowB, endrowE, endrowF)
Range(Cells(STARTROW, 1), Cells(endrowA, endcol1)).Select
End Function


Sub copy2place()
ConSName = ActiveSheet.Name & PZNAME


ActsheetName = ActiveSheet.Name

place = Sheets(ConSName).Range(cellplace).Value
sheetnname = Sheets(ConSName).Range(cellsheetnname).Value

'清空生成表中东西
If ActsheetName <> sheetnname And sheetnname <> "" Then
    Sheets(sheetnname).Select
    Range(place).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
End If

Sheets(ActsheetName).Select

If sheetnname = ActsheetName And place = startcell Then

ElseIf sheetnname <> "" And place <> "" Then
endrowA = Range("A65000").End(xlUp).row
endrowB = Range("B65000").End(xlUp).row
endrowE = Range("E65000").End(xlUp).row
endrowF = Range("F65000").End(xlUp).row
endcol1 = ActiveSheet.[IV1].End(xlToLeft).Column
endrow = Application.Max(endrowA, endrowB, endrowE, endrowF)
Range(Cells(STARTROW, 1), Cells(endrowA, endcol1)).Select
    Selection.Copy

    Sheets(sheetnname).Select
    Range(place).Select
    ActiveSheet.Paste
Dim ff
ff = Sheets(ConSName).Range(sheetnamecell).Value
dd = creatxlsxfile(ff, ActsheetName)
ActiveWorkbook.Sheets(ActsheetName).Select
Else

End If

'复制表名到a1
If ActsheetName <> sheetnname And sheetnname <> "" Then
    'Sheets(sheetnname).Range("a1") = Sheets(ActsheetName).Range("c1") '注释了暂时不用了
End If

'ActiveSheet.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

End Sub


Sub LilyVlookup()
Dim endrowA, findstr As String
endrowA = Range("A65000").End(xlUp).row
   For i = 3 To endrowA
      findstr = findstr & Cells(i, 1) & ","

   Next
Sheet1.Cells(3, 3) = findstr
Sheet1.Cells(3, 2) = "IN"
Sheet1.Cells(3, 1) = Sheet1.Cells(5, 6)
Sheet1.Activate
UpdateBySheet
Sheet6.Activate
End Sub




Public Function getclip()
On Error Resume Next
getclip = ""
Dim DataObj As New MSForms.DataObject
Dim S As String
DataObj.GetFromClipboard
aa = DataObj.GetText
getclip = aa
End Function


    '指定字符集的字符串转字节数组
Public Function datatostr(ByVal datestr)
If datestr = "" Then
datestr = "222"
Else
datestr = Application.Text(datestr, "0")
End If
End Function
                

Sub Delsheetdata()
Sheet2.Rows("1:65000").ClearContents
Sheet3.Rows("1:65000").ClearContents
Sheet4.Rows("1:65000").ClearContents

End Sub

Sub DeleteConn() '删除联接

    Dim oWC As WorkbookConnection
    For Each oWC In Excel.ThisWorkbook.Connections
        With oWC
            .Delete
        End With
    Next
End Sub





Public Function datetostr(ByVal datestr)
'Debug.Print datestr
 If datestr = "" Then
    datetostr = ""
 ElseIf InStr(datestr, ",") <> 0 Then
    datetostr = datestr
 Else
    datetostr = Application.Text(datestr, "0")
 End If
 
 
    
End Function


'弹窗提示是否更新
Sub PopUpdate(Optional msg As String = "")
ConSName = ActiveSheet.Name & PZNAME
    If (Sheets(ConSName).Range(popupdatecell).Value = "否") Then
         '不操作
    Else
        result = MsgBox(msg, 3, "通用查询系统")
        If result = 6 Then
            '不操作
        Else
            End
        End If
        'Debug.Print result
    End If
End Sub



Public Function UrlEncode(ByRef szString As String) As String
       Dim szChar   As String
       Dim szTemp   As String
       Dim szCode   As String
       Dim szHex    As String
       Dim szBin    As String
       Dim iCount1  As Integer
       Dim iCount2  As Integer
       Dim iStrLen1 As Integer
       Dim iStrLen2 As Integer
       Dim lResult  As Long
       Dim lAscVal  As Long
       szString = Trim$(szString)
       iStrLen1 = Len(szString)
       For iCount1 = 1 To iStrLen1
           szChar = Mid$(szString, iCount1, 1)
           lAscVal = AscW(szChar)
           If lAscVal >= &H0 And lAscVal <= &HFF Then
              If (lAscVal >= &H30 And lAscVal <= &H39) Or _
                 (lAscVal >= &H41 And lAscVal <= &H5A) Or _
                 (lAscVal >= &H61 And lAscVal <= &H7A) Then
                 szCode = szCode & szChar
              Else
                 szCode = szCode & "%" & Hex(AscW(szChar))
              End If
           Else
              szHex = Hex(AscW(szChar))
              iStrLen2 = Len(szHex)
              For iCount2 = 1 To iStrLen2
                  szChar = Mid$(szHex, iCount2, 1)
                  Select Case szChar
                         Case Is = "0"
                              szBin = szBin & "0000"
                         Case Is = "1"
                              szBin = szBin & "0001"
                         Case Is = "2"
                              szBin = szBin & "0010"
                         Case Is = "3"
                              szBin = szBin & "0011"
                         Case Is = "4"
                              szBin = szBin & "0100"
                         Case Is = "5"
                        szBin = szBin & "0101"
                         Case Is = "6"
                              szBin = szBin & "0110"
                         Case Is = "7"
                              szBin = szBin & "0111"
                         Case Is = "8"
                              szBin = szBin & "1000"
                         Case Is = "9"
                              szBin = szBin & "1001"
                         Case Is = "A"
                              szBin = szBin & "1010"
                         Case Is = "B"
                              szBin = szBin & "1011"
                         Case Is = "C"
                              szBin = szBin & "1100"
                         Case Is = "D"
                              szBin = szBin & "1101"
                         Case Is = "E"
                              szBin = szBin & "1110"
                         Case Is = "F"
                              szBin = szBin & "1111"
                         Case Else
                  End Select
              Next iCount2
              szTemp = "1110" & Left$(szBin, 4) & "10" & Mid$(szBin, 5, 6) & "10" & Right$(szBin, 6)
              For iCount2 = 1 To 24
                  If Mid$(szTemp, iCount2, 1) = "1" Then
                     lResult = lResult + 1 * 2 ^ (24 - iCount2)
                  Else: lResult = lResult + 0 * 2 ^ (24 - iCount2)
                  End If
              Next iCount2
              szTemp = Hex(lResult)
                    szCode = szCode & "%" & Left$(szTemp, 2) & "%" & Mid$(szTemp, 3, 2) & "%" & Right$(szTemp, 2)
           End If
szBin = vbNullString
           lResult = 0
       Next iCount1
       UrlEncode = szCode
End Function




'--------------------------------------------用不着的函数，备用-------------------------------------------------------------





Public Function Escape(ByVal strText As String) As String
Dim JS
    'Set JS = CreateObjectx("MSScriptControl.ScriptControl")   '正常使用
    Set JS = CreateObjectx86("MSScriptControl.ScriptControl")
    JS.Language = "JavaScript"
    Escape = JS.Eval("encodeURI('" & Replace(strText, "'", "\'") & "');")
End Function

Public Function Escape86(ByVal strText As String) As String
Dim JS

    Set JS = CreateObjectx86("MSScriptControl.ScriptControl")
    JS.Language = "JavaScript"
    Escape = JS.Eval("encodeURI('" & Replace(strText, "'", "\'") & "');")
End Function




Function URLDecode(ByVal What)
   Dim Pos, pPos

  'replace + To Space
   What = Replace(What, "+", " ")

  On Error Resume Next
  Dim Stream: Set Stream = CreateObject("ADODB.Stream")
  If Err = 0 Then 'URLDecode using ADODB.Stream, If possible
     On Error GoTo 0
    Stream.Type = 2 'String
     Stream.Open

    'replace all %XX To character
    Pos = InStr(1, What, "%")
    pPos = 1
    Do While Pos > 0
      Stream.WriteText Mid(What, pPos, Pos - pPos) + _
        Chr(CLng("&H" & Mid(What, Pos + 1, 2)))
      pPos = Pos + 3
      Pos = InStr(pPos, What, "%")
    Loop
    Stream.WriteText Mid(What, pPos)

    'Read the text stream
    Stream.Position = 0
    URLDecode = Stream.ReadText

    'Free resources
    Stream.Close
  Else 'URL decode using string concentation
    On Error GoTo 0
    'UfUf, this is a little slow method.
    'Do Not use it For data length over 100k
    Pos = InStr(1, What, "%")
    Do While Pos > 0
      What = Left(What, Pos - 1) + _
        Chr(CLng("&H" & Mid(What, Pos + 1, 2))) + _
        Mid(What, Pos + 3)
      Pos = InStr(Pos + 1, What, "%")
    Loop
    URLDecode = What
  End If
End Function





'产生随机数

Public Function sjs(n As Long) As String
Randomize
Dim ar, i, j, k
ReDim ar(1 To n)
For i = 1 To n
    ar(i) = Int(Rnd * 10)
    k = Int(Rnd * n + 1)
Next i
For j = 1 To k
    ar(Int(Rnd * n + 1)) = Chr(Int(Rnd * 26 + 65))
Next
sjs = Join(ar, "")
End Function

Sub 删除前两行()
    Rows("1:2").Select
    Selection.Delete Shift:=xlShiftUp
End Sub

Sub 首行居下()
    Rows("1:1").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = True
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
End Sub
Sub 行11行后缩小单元格()
ConSName = ActiveSheet.Name & PZNAME
    Rows(STARTROW + 1 & ":" & STARTROW + 1).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
        Range(Selection, Selection.End(xlDown)).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = True
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Rows(STARTROW & ":" & STARTROW).Select
End Sub
Sub updatesheet2()

  Dim aa As String
  Dim fromsheet, tosheet As String
  fromsheet = "Sheet1"
  tosheet = "Sheet2"
  
  Sheets(fromsheet).Select

    
    Sheets(tosheet).Select
    UploadExcel
      Sheets(fromsheet).Select
End Sub

Sub updateothersheets()
  Dim aa As String
…
vbaProject_00.bin vba-project OOXML VBA project: xl/vbaProject.bin 138240 bytes
SHA-256: c05ca96ce1bd99ac709643e1731aa3bf82b3c5ee7ea30c293f617b4d64021081
Detection
ClamAV: No threats found
Obfuscation or payload: likely
Carved artifact contains 1 eval/decoder/string-building token(s).

Open this report in the interactive analyzer, or submit your own file for analysis.