VBA下载

'File下载文件相关函数申明
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Public Declare Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long

Sub 批量下载()
自动下载导入 (0)
End Sub

Sub 下载导入()
关闭功能
自动下载导入 (1)
开启功能
End Sub

Sub 自动下载导入(Optional dr)
If IsMissing(dr) Then dr = 1 '为加了Optional的可选择性省略参数设定值
'感谢您查看本表源码，本源码和设计模式为本人原创，开源供交流学习， 有疑问可以联系我gzlinwancheng@jd.com 13570972484
'
'2016年11月25日 用通过查看会话关闭后失效的Cookie找到库存查询秘钥sso.jd.com设计出查ERP库存表格
'2016年11月26日 用ERP账号密码Post成功，设计出新的查库存与查订单站点表格给质控客服使用
'2016年11月28日 成功用Post后的Cookie打开JA表格
'2016年11月29日 成功用Post后的Cookie下载JA表格，分享
'2016年12月10日 休息日加班，增加批量导入等制作自动表的代码
'2016年12月11日 以日报举例，增加时间记录，合并下载和导入两部分代码
'2016年12月12日 完成WSG库房管家、SRM供应商预约系统Post导入，并调整Post/Get参数到表中设置
'2016年12月18日 下载地址参数用绝对引用$，以免复制粘贴到不同行时变化，增加说明
'2016年12月20日 编写Post下载地址获取说明，更改保存路径公式Cell函数增加参数以免选定其他表时地址变化
'2017年01月22日 增加File下载、手动导入、导入到已有指定列、导入并填充左右相邻公式（无需填充的不要相邻）、
' CSV导入使用数据导入并只在第一次自动调整裂开，第二行大于15位的列自动设置文本避免数据丢失
' 取消兼容按钮放其他表，界面表名可修改可多账号
' 时间提示改进，找不到对应列不导入以防公式表被破坏
' 快过年了仍把昨天休息和今晚加班用来写代码，京东价值观与程序员的自我修养哈哈哈
'2017年02月01日 手动导入增加多文件支持
'2017年02月08日 csv文件导入时清除原列内容，删除查询定义连接
'2017年02月28日 实现WMS数据自动抓取
'by 京东商城广州亚洲一号小件库 仓储质控部 园区质控岗 林万程

ssh = ActiveSheet.Name '为了兼容按钮放到其他表中

' Sheets("界面").Select '为了兼容按钮放到其他表中

ri = 5

' 联网提示 ("http://ssa.jd.com/sso/login")

Set http = CreateObject("Msxml2.ServerXMLHTTP")
    '登录
    http.Open "post", "http://ssa.jd.com/sso/login", False
    http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    Data = "username=" & [B2] & "&password=" & [B3] & "" '【ERP账号密码所在位置】
    http.send (Data)
    
    If InStr(http.responsetext, "登录超时") > 0 Then
        tip = Time & " 登录超时，ERP账号密码错误或未填写。"
        Debug.Print tip
        MsgBox tip
        End
    End If

'下载
For ri = 5 To [H1048576].End(xlUp).Row
If Range("B" & ri) <> "" Then '用下载表名判断，不导入的可以不填表名，这样不用去掉网址
    t1 = Time
    '报表下载保存地址
    ph = Range("A" & ri)
    If ph = "" Then ph = ThisWorkbook.path
    fn = ph & "\" & Range("B" & ri) & "." & Range("F" & ri)
    If Range("G" & ri) = "File" Then
        lngRetVal = URLDownloadToFile(0, Range("H" & ri), fn, 0, 0)
        If lngRetVal = 0 Then DeleteUrlCacheEntry Range("H" & ri)
    ElseIf Range("G" & ri) = "WMS" Then
        sq = [H1]
        sqt = Range("H" & ri)
        Workbooks.Add
        With ActiveSheet
        With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
            "ODBC;DRIVER={MySQL ODBC 5.3 Unicode Driver};" & sq, _
            Destination:=.Range("A1")).QueryTable
            .CommandText = sqt
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlOverwriteCells '插入模式=覆盖（还有插入行和插入列选择）f
            .SavePassword = True '保存密码
            .SaveData = True
            .AdjustColumnWidth = Ture
            .RefreshPeriod = 0 '刷新频率单位秒，0不自动刷新
            .PreserveColumnInfo = True
            .ListObject.DisplayName = "万程的缩写是WC"
            .Refresh BackgroundQuery:=False
            .Delete '删除查询定义
        End With
        End With
        ActiveWorkbook.SaveAs FileName:=fn, FileFormat:=xlCSV, CreateBackup:=False
        ActiveWindow.Close
    Else
        http.Open Range("G" & ri), Range("H" & ri), False
        http.send ("")
        DoEvents '防止程序假死
        
        Debug.Print attfn(http)

' If InStr(http.responsetext, "not support") > 0 Then
' tip = Time & " " & Range("B" & ri) & " 方法错误，请在网页中登录后运行，或更换有权限账号。"
' Debug.Print tip
'' MsgBox tip
' Else

        Set sGet = CreateObject("ADODB.Stream") '下载文件
            sGet.Mode = 3
            sGet.Type = 1
            sGet.Open
            sGet.Write (http.responseBody)
            sGet.SaveToFile SaveTo & fn, 2

' Set sGet = Nothing '清除文件流

' End If

        Application.ScreenUpdating = True '启用屏幕更新
        Range("E" & ri).Select '显示进度
        Application.ScreenUpdating = False '禁用屏幕更新
        If tip = Empty Then
            Range("E" & ri) = Time - t1
        Else
            Range("E" & ri) = tip
        End If
    End If
    
    '导入
    If dr = 1 Then
    If Range("C" & ri) <> "" Then '用导入表名判断，不导入的可以不填表名，这样不用去掉网址
    If Dir(fn, 16) <> Empty Then '路径不存在不运行，这里不加的话kill fn会报错
        s = Range("C" & ri)
        tip = 导入表(fn, s)
        Kill fn '删除文件
        
        Sheets(ssh).Select '打开导入过程选定表会变化，所以重新选定
        Application.ScreenUpdating = True '启用屏幕更新
        Range("E" & ri).Select '显示进度
        Application.ScreenUpdating = False '禁用屏幕更新
        If tip = Empty Then
            Range("E" & ri) = Time - t1
        Else
            Range("E" & ri) = tip
        End If
    End If
    End If
    End If
End If
Next

' Sheets(ssh).Select '为了兼容按钮放到其他表中
End Sub

Function decodeURI(szInput)
Set js = CreateObject("MSScriptControl.ScriptControl")
js.Language = "JScript"
decodeURI = js.Eval("decodeURI('" & szInput & "')")
End Function

Function attfn(http)
attfn = Replace(decodeURI(http.getResponseHeader("Content-Disposition")), "attachment;filename=", "")
End Function

Function 表存在(s)
For Each i In Sheets
If i.Name = s & "" Then 表存在 = 1 '连接空白是避免表格名为数值时格式不同
' Debug.Print i.Name = s
Next
End Function

Function 建表(s)
For Each i In Sheets
If i.Name = s Then Exit Function
Next
Sheets.Add(, ThisWorkbook.Sheets(Sheets.Count)).Name = s
' Sheets.Add.Name = s'创建在前面
' Sheets.Add 方法 (Excel)：https://msdn.microsoft.com/zh-cn/library/office/ff839847
End Function

Sub 更新WMS秘钥()
If 进程命令("SmartQueryTwo.exe") <> "" Then
[H1] = Split(进程命令("SmartQueryTwo.exe"), ",")(5)
End If
End Sub

Function 测网(url)
On Error Resume Next
cmdping = "ping " & url & " -n 1"
Set oExec = CreateObject("Wscript.shell").exec(cmdping)
Do Until oExec.stdout.AtEndOfStream
strline = strline & oExec.stdout.readline() & Chr(13)
Loop
测网 = 0
If InStr(strline, "回复") Then 测网 = 1
Set oExec = Nothing
End Function

Function 联网提示(url)
If 测网(url) = 0 Then
tip = Time & " 请确认是否连接上公司内网。"
Debug.Print tip
MsgBox tip
End
End If
End Function