Malicious Office (OOXML) — malware analysis report

Static analysis result for SHA-256 7e1f9802dad25596…

MALICIOUS

Office (OOXML)

90.0 KB Created: 2017-09-22 01:14:00 UTC Authoring application: Microsoft Excel First seen: 2021-10-23
MD5: 9ab6f645953d415d8be28067a0d3607d SHA-1: b61edbbe60ac54c4b08423e553eb8290a2917e79 SHA-256: 7e1f9802dad2559678171a8e82c41d32135fdb917033b4078c31b0b6e5fd4f52
342 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1204.002 Malicious File T1071.001 Web Protocols T1105 Ingress Tool Transfer

The sample is an Excel document containing VBA macros that leverage WScript.Shell and cmd.exe to download and execute a second-stage payload from the 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'. The document body contains financial transaction-like data, likely intended to appear legitimate. The VBA macro's use of URLDownloadToFile and Shell() calls indicates a clear intent to fetch and run external code.

Heuristics 9

  • VBA project inside OOXML medium 5 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
    exeurl = "D:\老黄牛小工具\小工具\缩小图片nconvert\nconvert.exe -out jpeg -clipboard -overwrite -o " & TEMPMDIMG
'Call Shell(exeurl, 0)
ret = oShell.Run(exeurl, 1, True)
  • WScript.Shell usage critical OLE_VBA_WSCRIPT
    WScript.Shell usage
    Matched line in script
    '调用截图程序截图到剪贴板
Set oShell = CreateObject("WSCript.shell")
ret = oShell.Run("D:\老黄牛小工具\小工具\360screener.exe", 1, True)
  • URLDownloadToFile in VBA critical OLE_VBA_DOWNLOAD
    URLDownloadToFile in VBA
    Matched line in script
    #If VBA7 Then
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Integer, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As LongPtr, ByVal lpfnCB As LongPtr) As LongPtr
#Else
  • 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
  • cmd.exe reference in VBA high OLE_VBA_CMD
    cmd.exe reference in VBA
    Matched line in script
    '强制关闭截图程序
Shell "cmd.exe /c taskkill /IM 360screener.exe /F"
  • 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 Referenced by macro

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) 41906 bytes
SHA-256: 2fb8b067e35d5977b887d7084a10fb387481ee21d2e45f972f236609ab38e087
Detection
ClamAV: No threats found
Obfuscation or payload: likely
Carved artifact contains 2 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 = "基础软件" '辅助文件夹

'引用下载文件的api，如果出错，换一下即可
#If VBA7 Then
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Integer, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As LongPtr, ByVal lpfnCB As LongPtr) As LongPtr
#Else
    Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Integer, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Integer, ByVal lpfnCB As Long) As Integer
#End If

Sub 主表下载数据()
ConSName = ActiveSheet.Name
ConSName = Replace(ConSName, PZNAME, "")
Sheets(ConSName).Select
UpdateBySheet
End Sub
Sub 主表上传数据()
ConSName = ActiveSheet.Name
ConSName = Replace(ConSName, PZNAME, "")
Sheets(ConSName).Select
UploadExcel
End Sub

'执行宏命令
Sub 执行1上传_2下截_3上传()
Sheets("1.原始表").Select
UploadExcel

Sheets("2.临时下载表").Select
UpdateBySheet

Sheets("3.分表上传").Select
UploadExcel
Sheets("1.原始表").Select
End Sub

'执行宏命令
Sub 执行1下截_2筛选_3上传()
Sheets("sheet1").Select
UpdateBySheet

Sheets("sheet2").Select
Range("D21").Select
ActiveSheet.AutoFilter.ApplyFilter

UploadExcel
Sheets("sheet1").Select
End Sub
'点击单元格的数据
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






'按照网站的目录样式下载文件方便转移
Sub UpdateBySheet_byweb()
Call UpdateBySheet("web")
End Sub








Function creatxlsxfile(ByVal filename As String, ByVal ActsheetName As String)
ConSName = ActsheetName & PZNAME
sheetnname = Sheets(ConSName).Range(cellsheetnname).Value
   Application.DisplayAlerts = False
    Sheets(sheetnname).Select
    Sheets(sheetnname).Copy
    ChDir ThisWorkbook.path
    ActiveWorkbook.SaveAs filename:=ThisWorkbook.path & "/" & filename & ".xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
    Sheets(sheetnname).Select
End Function


'替换随机两个字为随机数

Public Function replacesjpassword(ByVal cellstr As String, ByVal n As Long) As String
ConSName = ActiveSheet.Name & PZNAME

Dim ss As String

ss = Sheets(ConSName).Range(cellstr).Value
If ss Like "*随机*" Then
    replacesjpassword = Replace(ss, "随机", sjs(n))
Else
    replacesjpassword = ss
End If

End Function

Sub delpassword()
ConSName = ActiveSheet.Name & PZNAME
    If (Sheets(ConSName).Range(delpasswordcell).Value = "是") Then
        Sheets(ConSName).Range(sitepassword) = ""
        Sheets(ConSName).Range(wrpwcell) = ""

    End If
End Sub


Sub test()
  Dim a As Variant
   Dim b As Variant
   Dim filename As String
   

   a = Split(Sheets(ConSName).Range(cellfilenamecol).Value, ",")
   b = UBound(a)

   filename = ""
   For i = 0 To b
    If i < b Then
      filename = filename & a(i) & SepChar
    Else
      filename = filename & a(i)
    End If
   Next

End Sub
'判断一下是不是网址
Function isurl(ByVal url As String)
If Mid(url, 1, 4) = "http" Then
    isurl = True
ElseIf Mid(url, 1, 1) = "/" Then
    isurl = True
Else
    isurl = False
End If
End Function

'获取curl.exe的目录
Function getcurlpath(ByVal exe As String)
nowcurlpath = CURLPATH & "\" & exe
If IsFileExists(nowcurlpath) Then
    getcurlpath = nowcurlpath
Else
    getcurlpath = ThisWorkbook.path & "\" & FZFLOLDER & "\" & exe
End If
    



End Function


'重命名文件
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 最小化全部工作簿并截图()

'隐藏窗口
Application.WindowState = xlMinimized
    
'延迟一秒执行
Application.Wait Now() + CDate("00:00:01")

'删除临时文件
Set fso = CreateObject("scripting.filesystemobject")
If fso.FileExists(TEMPMDIMG) Then
    fso.DeleteFile TEMPMDIMG, True
End If

'调用截图程序截图到剪贴板
Set oShell = CreateObject("WSCript.shell")
ret = oShell.Run("D:\老黄牛小工具\小工具\360screener.exe", 1, True)
'把剪贴板的图象保存为jpg文件
exeurl = "D:\老黄牛小工具\小工具\缩小图片nconvert\nconvert.exe -out jpeg -clipboard -overwrite -o " & TEMPMDIMG
'Call Shell(exeurl, 0)
ret = oShell.Run(exeurl, 1, True)
'强制关闭截图程序
Shell "cmd.exe /c taskkill /IM 360screener.exe /F"

'最大化窗口
Application.WindowState = xlMaximized


End Sub

'截图网络上传文件
Sub 截图网络上传文件()
Set fso = CreateObject("scripting.filesystemobject")
Dim filepath As String
filepath = TEMPMDIMG

Call 最小化全部工作簿并截图
If fso.FileExists(TEMPMDIMG) Then
    Call 弹窗表格网络上传文件(filepath)
Else
    MsgBox ("没有成功截图！~")
End If


'Call 表格上传文件公共区("表格网络上传文件", filepath)

End Sub

'剪贴板上传文件
Sub 剪贴板上传文件()
Set fso = CreateObject("scripting.filesystemobject")
Dim filepath As String


'调用外部程序获取已复制文件的路径
Set oShell = CreateObject("WSCript.shell")
ret = oShell.Run("D:\老黄牛小工具\小工具\AutoHotkey.exe  D:\老黄牛小工具\小工具\ahk\剪贴板转路径.ahk", 1, True)
filepath = getclip()

If fso.FileExists(filepath) Then
    Call 弹窗表格网络上传文件(filepath)
Else
    MsgBox ("没有成功复制文件！~")
End If



'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
                                    returnurl = Postfile(filepath) '网络上传
                                    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




Sub CopyToClipbox(strText As String)
    '文本拷贝到剪贴板
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .SetText strText
        .PutInClipboard
    End With
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)
…
vbaProject_00.bin vba-project OOXML VBA project: xl/vbaProject.bin 103936 bytes
SHA-256: 9c574887588cf0e46073b044955b7cec7d0e796e79028a9663746356824b8b6f

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