Malicious Office (OOXML) — malware analysis report

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(Optional downtype As String = "")   '本地更新表格,
ConSName = ActiveSheet.Name & PZNAME
If (Sheets(ConSName).Range(rpwcell).Value = "") Then
    MsgBox ("请输入查看密码。")
Else
Call PopUpdate("从服务器上下载数据，本地数据将被清空！~")

'读取配置
Dim url, OnlyURL, user, pw, con, field, i, weburl, updateweb
Dim conditon(conmaxline * 3) As String, conall As String
   For i = 1 To conmaxline - 1
    If (Sheets(ConSName).Cells(i, 1) <> "" Or Sheets(ConSName).Cells(i, 2) <> "" Or Sheets(ConSName).Cells(i, 3) <> "") Then
      conditon(i) = datetostr(Sheets(ConSName).Cells(i, 1)) & datetostr(Sheets(ConSName).Cells(i, 2)) & datetostr(Sheets(ConSName).Cells(i, 3))
      conall = conall & conditon(i) & ";"
    End If
   Next

'第二列部分的读取
   For i = 1 To 1
       If (Sheets(ConSName).Cells(i, 6) <> "") Then
        conditon(i) = datetostr(Sheets(ConSName).Cells(i, 5)) & "等于" & datetostr(Sheets(ConSName).Cells(i, 6))
        conall = conall & conditon(i) & ";"
        'Debug.Print conditon(i)
      End If
   Next
   For i = 3 To 4
       If (Sheets(ConSName).Cells(i, 6) <> "") Then
        conditon(i) = datetostr(Sheets(ConSName).Cells(i, 5)) & "等于" & datetostr(Sheets(ConSName).Cells(i, 6))
        conall = conall & conditon(i) & ";"
        'Debug.Print conditon(i)
      End If
   Next
   
   
   
'网站设置

' 用户名与密码都不为空，那就上传到com
Dim truedownurl
If ((Sheets(ConSName).Range(siteuer).Value <> "") And (Sheets(ConSName).Range(sitepassword).Value) <> "") Then
    truedownurl = downurlcom
Else
    truedownurl = downurl
End If

weburl = Sheets(ConSName).Range(website).Value & truedownurl

'conall = Escape("conall=" & conall)
conall = "conall=" & UrlEncode(conall)












OnlyURL = weburl & conall
url = "url;" & OnlyURL
'sheets(ConSName).cells(10, 4) = OnlyURL
'MsgBox (pw)
 Sheets(ConSName).Range(downurldebugcell).Value = OnlyURL
    
    
    '如果开启了筛选模式则关闭该模式
    Range(startcell).Select
    If ActiveSheet.AutoFilterMode = True Then
        ActiveSheet.AutoFilterMode = False
    End If


备份第一行的样式

Rows(STARTROW & ":65000").ClearContents

With ActiveSheet.QueryTables.Add("url;" & weburl, Range("a" & STARTROW))
    .PostText = conall
    .RefreshStyle = xlInsertDeleteCells  '不含格式
    .AdjustColumnWidth = False           '自动调整列宽
    .Refresh False
End With

'Debug.Print weburl
'缩小单元格
行11行后缩小单元格
'首行居下

还原第一行的样式

'复制到指定地方
copy2place




End If

'删除所有的数据连接
DeleteConn
'回车符转换
回车符转换成回车

'从网站上下载文件
If Sheets(ConSName).Range(cellautodownloadfile).Value = "是" Then
    downloadfiles
ElseIf Sheets(ConSName).Range(cellautodownloadfile).Value = "是，网站结构下载" Then
    downloadfilesbyweb
End If


End Sub




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






Sub UploadExcel() '上传表格
ConSName = ActiveSheet.Name & PZNAME
Call PopUpdate("上传并覆盖服务器上的数据，请警慎操作！~？")

'随机两个字的替换
Sheets(ConSName).Range(rpwcell).Value = replacesjpassword(rpwcell, 10)
Sheets(ConSName).Range(wrpwcell).Value = replacesjpassword(wrpwcell, 14)
Sheets(ConSName).Range(sheetnamecell).Value = replacesjpassword(sheetnamecell, 2)

'自动筛选的更新
'自动筛选的更新
    On Error Resume Next
Range(startcell).Select
ActiveSheet.AutoFilter.ApplyFilter


If (Sheets(ConSName).Range(rpwcell).Value = "") Or (Sheets(ConSName).Range(wrpwcell).Value = "") Then
    MsgBox ("请输入上传密码及查看密码。" & Chr(10) & Chr(13) & Chr(10) & Chr(13) & "3到8行可能被隐藏了，请先取消隐藏。")
Else
'读取配置
Dim url, OnlyURL, user, pw, con, field, i, weburl, updateweb
Dim conditon(conmaxline * 3) As String, conall As String
   For i = 1 To conmaxline
    If (Sheets(ConSName).Cells(i, 1) <> "" Or Sheets(ConSName).Cells(i, 2) <> "" Or Sheets(ConSName).Cells(i, 3) <> "") Then
      conditon(i) = datetostr(Sheets(ConSName).Cells(i, 1)) & datetostr(Sheets(ConSName).Cells(i, 2)) & datetostr(Sheets(ConSName).Cells(i, 3))
      conall = conall & conditon(i) & ";"
    End If
   Next

   For i = 1 To conmaxline
       If (Sheets(ConSName).Cells(i, 5) <> "" Or Sheets(ConSName).Cells(i, 6) <> "") Then
        conditon(i) = datetostr(Sheets(ConSName).Cells(i, 5)) & "等于" & datetostr(Sheets(ConSName).Cells(i, 6))
        conall = conall & conditon(i) & ";"
        'Debug.Print conditon(i)
      End If
   Next
   
   
   For i = 1 To conmaxline
    If (Sheets(ConSName).Cells(i, 9) <> "" Or Sheets(ConSName).Cells(i, 10) <> "") Then
       conditon(i) = datetostr(Sheets(ConSName).Cells(i, 9)) & "等于" & datetostr(Sheets(ConSName).Cells(i, 10))
       conall = conall & conditon(i) & ";"
     End If
   Next
   
'Debug.Print conall



'网站设置

'weburl = sheets(ConSName).cells(4, 10) & downurl
' 用户名与密码都不为空，那就上传到com
Dim trueupurl
If ((Sheets(ConSName).Range(siteuer).Value <> "") And (Sheets(ConSName).Range(sitepassword).Value) <> "") Then
    trueupurl = upurlcom
Else
    trueupurl = upurl
End If




updateweb = Sheets(ConSName).Range(website).Value & trueupurl

Dim Filesavefolder

Filesavefolder = Environ("TEMP") & "\"
'Debug.Print updateweb & conall

endrowA = Range("A65000").End(xlUp).row
endrowB = Range("B65000").End(xlUp).row
endrowE = Range("E65000").End(xlUp).row
endrowF = Range("F65000").End(xlUp).row
endrow = Application.Max(endrowA, endrowB, endrowE, endrowF)
    Rows(STARTROW & ":" & endrow).Select
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    'Selection.NumberFormatLocal = "@"

'关闭文件覆盖提示
Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs filename:=Filesavefolder & "upload.csv", _
        FileFormat:=xlCSV, CreateBackup:=False


'补全d1,d2,d3,.....,d50
    Rows("1:1").Select
    Selection.Insert Shift:=xlShiftDown
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "d1"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "d2"
    Range("A1:B1").Select
    Selection.AutoFill Destination:=Range("A1:AX1"), Type:=xlFillDefault

ActiveWorkbook.Save
    ActiveWindow.Close
    
Dim UploadData, FileFullPath, tempFileName, loadStatus
FileFullPath = Filesavefolder & "upload.csv"
tempFileName = "upload.csv"
Set UploadData = New XMLUpload

UploadData.Charset = "utf-8"
UploadData.AddForm "conall", conall '文本域的名称和内容
UploadData.AddFile "file", tempFileName, "application/octet-stream", FileFullPath
Debug.Print updateweb & "conall=" & conall
loadStatus = UploadData.Upload(updateweb)


   Dim f As String
     f = ThisWorkbook.Path & "/" & Sheets(ConSName).Range(sheetnamecell).Value & GLWY
     Open f For Output As #1
     Print #1, loadStatus
     Close #1




    Dim WriteStream As Object
    Set WriteStream = CreateObject("ADODB.Stream")
    With WriteStream
        .Type = 2               'adTypeText
        .Charset = "UTF-8"
        .Open
        .WriteText loadStatus
        .SaveToFile ThisWorkbook.Path & "/" & Sheets(ConSName).Range(sheetnamecell).Value & GLWY, 2  'adSaveCreateOverWrite
        .Flush
        .Close
        
    End With
    Set WriteStream = Nothing
    





Set fso = Nothing
Set UploadData = Nothing

    


'Application.Wait Now + TimeValue("00:00:01")
'这里是打开网页，方便上传
resultweb = ThisWorkbook.Path & "/" & Sheets(ConSName).Range(sheetnamecell).Value & GLWY

ActiveWorkbook.FollowHyperlink resultweb

End If
'删除所有的数据连接
DeleteConn
'删除上传密码与用户密码
delpassword
'删除upload.xlsx临时文件
'DeleteTemp

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 downloadfiles(Optional downtype As String = "")
ConSName = ActiveSheet.Name & PZNAME
Application.ScreenUpdating = False
Dim iRow, i, S, ext, savename, url, urlall
Dim savePath  '保存路径

    On Error Resume Next
'保证下载目录的存在，并保证没有文件
Set fso = CreateObject("scripting.filesystemobject")
savePath = ThisWorkbook.Path & "\" & Sheets(ConSName).Range(FILESAVEPATHCELL) & "\"
nowcurlpath = getcurlpath("curl.exe")
MkDir savePath







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(Sheets(ConSName).Cells(STARTROW, 1), Sheets(ConSName).Cells(endrowA, endcol1)).Select




k = 1
For i = STARTROW + 1 To endrow
    For S = 1 To endcol1
        k = k + 1
            If Cells(i, S) <> "" Then
                url = Cells(i, S)
                ext = fso.GetExtensionName(url)
                filename = renamefilename(i, S)
                savePath = ThisWorkbook.Path & Mkcelldir2nodel(i, S)
                savename = filename & "." & ext
                NewFile = Replace(savePath & "\" & savename, "/", "\")
                NewFile = Replace(NewFile, "\\", "\")
                NewFile = Replace(NewFile, "\\", "\")
                If Mid(url, 1, 1) = "/" Then
                    urlall = Sheets(ConSName).Range(website).Value & Mid(url, 1, Len(url))
                End If

                If isurl(url) Then
                    If IsFileExists(NewFile) Then
                        a = "a" '存在不做任何事
                        
                    Else
                        If downtype = "web" Then
                            Dim folder2
                            folder2 = Mid(url, 1, InStrRev(url, "/"))
                            folder2 = Replace(savePath & folder2, "/", "\")
                            Call CreateFolders(folder2)
                            NewFile = Replace(savePath & "\" & url, "/", "\")
                            NewFile = Replace(NewFile, "\\", "\")
                        Else
                            NewFile = Replace(savePath & "\" & savename, "\\", "\")
                        End If
                        
                            URLDownloadToFile 0, urlall, NewFile, 0, 0
                         'runc = nowcurlpath & " -o " & NewFile & " " & urlall
                         'Shell runc
                         'CreateObject("WScript.Shell").Run runc, 0    '强行注释，要不会报毒
                    End If
                        
                End If
                
            End If
    Next S
Next i
Application.ScreenUpdating = True
End Sub


'按照网站的目录样式下载文件方便转移
Sub downloadfilesbyweb()
Call downloadfiles("web")
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
…