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

相关文章

来自专栏游戏杂谈

as3与php 上传单个图片demo

1、单个上传使用FileReference,一次可选择多张图片可使用FileReferenceList,在flash player 10+可使用load方法可实...

2003
来自专栏Pythonista

牛掰的python与unix

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

1162
来自专栏子勰随笔

URL编码中的空格(编码以后变为+)

27210
来自专栏向治洪

Android杀毒实现原理及实例

一个杀毒软甲最核心的部分一个是病毒库一个是杀毒引擎,病毒库从服务器中获得,杀毒引擎实际上是判断程序中的包名和签名是否匹配病毒库中的包名和签名,如果匹配则为病毒,...

2817
来自专栏Java学习之路

JavaTCP和UDP套接字编程

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

3465
来自专栏我和未来有约会

如何在silverlihgt中使用右键

一般我们在silverlight中点击右键会出现如下的对话筐. ? ? 在flash中 其提供了一个可定制话的右键菜单系统.(ContextMenu) 这个...

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

C# http Get/POST请求封装类

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

7742
来自专栏葡萄城控件技术团队

扩展GridView控件——为内容项添加拖放及分组功能

引言 相信大家对GridView都不陌生,是非常有用的控件,用于平铺有序的显示多个内容项。打开任何WinRT应用或者是微软合作商的网站,都会在APP中发现Gri...

3615
来自专栏Python小屋

Python回文判断代码优化与6个思考题

送个福利:清华大学出版社和新宝图书专营店联合推出正版特价图书《Python程序设计开发宝典》,原价69元,特价47.6元,详情:https://detail.t...

3656
来自专栏恰童鞋骚年

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

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

1252

扫码关注云+社区

领取腾讯云代金券