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

相关文章

来自专栏飞扬的花生

Html5上传插件封装

      前段时间将flash的上传控件替换成使用纯js实现的,在此记录 1.创建标签 <div class="camera-area" style="dis...

2028
来自专栏令仔很忙

机房收费系统——VB将MSHflexgrid控件中的数据导出为Excel

 在做机房收费系统的时候,许多窗体用到的一个功能,就是将从数据库中提取出来的数据导出到Excel中。

561
来自专栏互联网开发者交流社区

窗体应用程序防腾讯QQ源码

1344
来自专栏禹都一只猫博客

Sublime Text 3常用插件

1806
来自专栏安恒网络空间安全讲武堂

CrackMe破解之Delphi

刚开始学逆向,先学了OD的使用,学了个大概之后就开始了实践,边学习边实践,破解一些crackme,因为是刚开始入门,所以有些算法还是不理解,无法逆向出算法,但是...

801
来自专栏草根专栏

使用angular4和asp.net core 2 web api做个练习项目(一)

这是一篇学习笔记. angular 5 正式版都快出了, 不过主要是性能升级. 我认为angular 4还是很适合企业的, 就像.net一样. 我用的是wind...

5775
来自专栏c#开发者

Use P/Invoke to Develop a .NET Base Class Library for Serial Device Communications

Serial Comm Use P/Invoke to Develop a .NET Base Class Library for Serial Device ...

33914
来自专栏c#开发者

在DataGrid中选择,确认,删除多行复选框列表

在DataGrid中选择,确认,删除多行复选框列表 Selecting, Confirming & Deleting Mul...

3537
来自专栏阿炬.NET

【要什么自行车】ASP.NET MVC4笔记02:上传文件 uploadify 组件使用

2885
来自专栏Kubernetes

kube-proxy源码分析

##kube-proxy介绍 请参考我的另一篇博文:kube-proxy工作原理 ##源码目录结构分析 cmd/kube-proxy //负责kub...

4015

扫码关注云+社区