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 条评论
登录 后参与评论

相关文章

来自专栏Android 研究

Android Handler机制7之消息发送

光看上面这些API你可能会觉得handler能法两种消息,一种是Runnable对象,一种是message对象,这是直观的理解,但其实post发出的Runnab...

921
来自专栏Java学习之路

JavaTCP和UDP套接字编程

原文地址:http://www.cnblogs.com/MindMrWang/p/8919890.html 在我们刚开始入门Java后端的时候可能你会觉得有点...

762
来自专栏编程之旅

iOS开发——带有暂停功能的计时器

上篇博客我跟大家分享了如何在iOS系统中使用原生框架获取步数,又是大半个月过去了,运动模块的全部功能也总算完成了,也打算有始有终的把如何做一个跑步类App跟大家...

1731
来自专栏Laoqi's Linux运维专列

利用iptables防止syn flood攻击

3304
来自专栏SDNLAB

源码解读ODL的MAC地址学习(一)

1 简介 我们知道同一子网中主机之间互相传送信息需要用到MAC地址,而我们第一次发送信息的时候只有IP地址而没有MAC地址,所以我们就要进行MAC地址自学习。 ...

7156
来自专栏恰同学骚年

ASP.Net MVC开发基础学习笔记:二、HtmlHelper与扩展方法

  在ASP.Net MVC中微软并没有提供类似服务器端控件那种开发方式,毕竟微软的MVC就是传统的请求处理响应的回归。所以抛弃之前的那种事件响应的模型,抛弃服...

1112
来自专栏菩提树下的杨过

flash/flex 与 FluorineFx通讯之Hello World!

Bēniaǒk兄弟的Flex与.NET互操作(六):Flex和.NET协同开发利器FluorineFx 是基于vs2008 + flex builder3的,不...

2046
来自专栏雪胖纸的玩蛇日常

Uncaught SyntaxError: Unexpected token ' in JSON at position 1

4713
来自专栏Pythonista

牛掰的python与unix

  加载subprocess模块仅仅是将可以使用的代码文件加载进来。也可以创建自己的模块或文件,拱以后重复使用,这与加载subprocess模块的方法相同。IP...

1032
来自专栏跟着阿笨一起玩NET

C# http Get/POST请求封装类

http://www.sufeinet.com/thread-3-1-1.html

4992

扫码关注云+社区