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

本文参与腾讯云自媒体分享计划,欢迎正在阅读的你也加入,一起分享。

发表于

我来说两句

0 条评论
登录 后参与评论

相关文章

来自专栏张善友的专栏

LINQ via C# 系列文章

LINQ via C# Recently I am giving a series of talk on LINQ. the name “LINQ via C...

2675
来自专栏Ceph对象存储方案

Luminous版本PG 分布调优

Luminous版本开始新增的balancer模块在PG分布优化方面效果非常明显,操作也非常简便,强烈推荐各位在集群上线之前进行这一操作,能够极大的提升整个集群...

3255
来自专栏ASP.NETCore

ASP.NET Core 整合Autofac和Castle实现自动AOP拦截

除了ASP.NETCore自带的IOC容器外,我们还可以使用其他成熟的DI框架,如Autofac,StructureMap等(笔者只用过Unity,Ninjec...

684
来自专栏Golang语言社区

【Golang语言社区】GO1.9 map并发安全测试

var m sync.Map //全局 func maintest() { // 第一个 YongHuomap := make(map[st...

4838
来自专栏java 成神之路

使用 NIO 实现 echo 服务器

4807
来自专栏张善友的专栏

Mix 10 上的asp.net mvc 2的相关Session

Beyond File | New Company: From Cheesy Sample to Social Platform Scott Hansel...

2627
来自专栏张善友的专栏

Miguel de Icaza 细说 Mix 07大会上的Silverlight和DLR

Mono之父Miguel de Icaza 详细报道微软Mix 07大会上的Silverlight和DLR ,上面还谈到了Mono and Silverligh...

2727
来自专栏大内老A

The .NET of Tomorrow

Ed Charbeneau(http://developer.telerik.com/featured/the-net-of-tomorrow/) Exciti...

32610
来自专栏张善友的专栏

Silverlight + Model-View-ViewModel (MVVM)

     早在2005年,John Gossman写了一篇关于Model-View-ViewModel模式的博文,这种模式被他所在的微软的项目组用来创建Expr...

3028
来自专栏落花落雨不落叶

canvas画简单电路图

65111

扫码关注云+社区