ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: 怪盗KID

[求助] 海淘族求宏程序自动抓取雅虎信息

[复制链接]

TA的精华主题

TA的得分主题

发表于 2015-1-3 09:27 | 显示全部楼层
本帖最后由 bluexuemei 于 2015-1-3 17:57 编辑

关于提取文档程序
1,有的价格不正确,不知道为什么,已经在附件标注黄色。(当时没有考虑到千分号,已修改)
2,有一个宝贝名称死活出不来,很奇怪。(附件倒数第二行)(中间那个黑点惹的祸,导致转码失败)
3,第4行的名称为粗体字,原因是?(是你不小心按了工具栏中的字体加粗)完整程序如下:
  1. Sub getwebdata提取文本() '提取文本
  2. ' http://www.artonx.org/data/asr/Ruby-2.1.1.msi
  3.     Dim url$, y$, info, bname$, ojs As Object
  4.     Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript"
  5.      For Each cell In Selection
  6.          url = cell.Value
  7.          y = ojs.eval("require 'open-uri';$r='decTxtAucPrice,StartPrice,decTxtBuyPrice,EndTime,SellerID'.split(',');$s=open(%Q(" & url & "),&:read).to_s")
  8.          info = ojs.eval("$r.map{|p|$s.scan(/#{p}"">([\s\S]*?)</)[0]}.flatten.map{|x|x.to_s.encode('gbk').gsub(/\s+/,'')}.map.with_index{|x,i|i<3?x[/[\d,]+/]:x}")
  9.          bname = ojs.eval("$s.scan(/title>(.+?)(?=\-)/)[0][0].split(//).select{|x|x.ord!=12539}.join.encode('gbk')")
  10.          cell(1, 2).Resize(1, 5) = info
  11.          cell(1, -1) = bname
  12.     Next
  13.     Set ojs = Nothing
  14.     'Stop
  15. End Sub
  16. Sub getwebpicture提取图片() '提取图片
  17.    'http://www.artonx.org/data/asr/Ruby-2.1.1.msi
  18.     Dim url$, bname$, img, cell As Range, ojs As Object
  19.     Dim nUrl As String, localFilename As String
  20.     Dim XmlHttp As Object, ayrHttpBody() As Byte
  21.     Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript": ojs.timeout = -1
  22.     Set XmlHttp = CreateObject("Microsoft.XMLHTTP")
  23.     On Error Resume Next
  24.     For Each cell In Selection
  25.          url = cell.Value
  26.          y = ojs.eval("require 'open-uri';$s=open(%Q(" & url & "),&:read)")
  27.          bname = ojs.eval("$s.scan(/title>(.+?)(?=\-)/)[0][0].split(//).select{|x|x.ord!=12539}.join.encode('gbk')")
  28.          img = ojs.eval("$s.scan(/<img src\=""(.+?.jpg)/).flatten")
  29.          Debug.Print img
  30.          subfolder = Trim(Replace(bname, "/", "")) & Replace(Round(Rnd(), 3), ".", "")
  31.          MkDir ThisWorkbook.Path & "" & subfolder

  32.          For i = 0 To UBound(img)
  33.             nUrl = img(i)
  34.             localFilename = ThisWorkbook.Path & "" & subfolder & "" & i + 1 & ".jpg"
  35.             XmlHttp.Open "GET", nUrl, True       '异步下载
  36.             XmlHttp.Send
  37.             Do Until XmlHttp.ReadyState = 4
  38.                 DoEvents
  39.             Loop
  40.             If XmlHttp.Status = 200 Then
  41.                ayrHttpBody() = XmlHttp.ResponseBody
  42.                Open localFilename For Binary As #1
  43.                Put #1, , ayrHttpBody()
  44.                Close #1
  45.             End If
  46.          Next
  47.     Next
  48.     Set XmlHttp = Nothing
  49.     Set ojs = Nothing
  50.     'Stop
  51. End Sub
  52. Sub addcomment添加图片批注() '添加图片批注
  53. ' http://www.artonx.org/data/asr/Ruby-2.1.1.msi
  54.     Dim url$, bname$, img$, cell As Range, ojs As Object
  55.     Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript"
  56.     On Error Resume Next
  57.     For Each cell In Selection
  58.          url = cell.Value
  59.          y = ojs.eval("require 'open-uri';$s=open(%Q(" & url & "),&:read)")
  60.          bname = ojs.eval("$s.scan(/title>(.+?)(?=\-)/)[0][0].encode('gbk')")
  61.         img = ojs.eval("$s.scan(/<img src\=""(.+?.jpg)/)[0][0]")
  62.          With cell(1, -1)
  63.            .ClearComments
  64.            .addcomment
  65.            .Comment.Shape.Fill.UserPicture img
  66.            .Comment.Shape.Height = 450
  67.            .Comment.Shape.Width = 600
  68.          End With
  69.    
  70.     Next
  71.     Set ojs = Nothing
  72.     'Stop
  73. End Sub
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-1-2 22:07 | 显示全部楼层
bluexuemei 发表于 2015-1-2 17:18

刚才试了一下第一次的程序,对倒数第二行依旧失效,什么也调不出来,真奇怪

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-1-3 12:21 | 显示全部楼层
测试了一下,感觉后两个程序的BUG都解决了,但是第一个程序调出来的都是乱码,或者空白。bluexuemei 兄看一下附件。

日雅自动读取信息测试1.3.rar

257.18 KB, 下载次数: 2

点评

已经更正,请看32#  发表于 2015-1-3 13:25

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-1-3 16:04 | 显示全部楼层
@bluexuemei 兄,还是有问题,提示运行时错误‘13,类型不匹配。
卡在语句
info = ojs.eval("$r.map{|p|$s.scan(/#{p}"">([\s\S]*?)</)[0]}.flatten.map{|x|x.to_s.encode('gbk').gsub(/\s+/,'')}.map.with_index{|x,i|i<3?x[/[\d,]+/]:x}")

TA的精华主题

TA的得分主题

发表于 2015-1-3 16:07 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-1-3 16:30 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
bluexuemei 发表于 2015-1-3 16:07
上传出错的网址

都出错,没有能正确执行的好像

TA的精华主题

TA的得分主题

发表于 2015-1-3 16:56 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
我这里完全正常。

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-1-3 17:37 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
上传我的附件,确实一个也无法成功调用,是否是还需要安装别的什么MSI。朋友加我QQ,实在不行帮我远程协助一下看看

日雅自动读取信息测试1.3.2.rar

18 KB, 下载次数: 3

点评

哦,变量声明有问题,请再看32楼  发表于 2015-1-3 18:01

TA的精华主题

TA的得分主题

发表于 2015-1-3 19:26 | 显示全部楼层
  1. Sub getwebdata提取文本1() '提取文本
  2. ' http://www.artonx.org/data/asr/Ruby-2.1.1.msi
  3.     Dim url, y
  4.     Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript"
  5.      For Each cell In Selection
  6.          url = cell.Value
  7.          y = ojs.eval("require 'open-uri';$r='decTxtAucPrice,StartPrice,decTxtBuyPrice,EndTime,SellerID'.split(',');$s=open(%Q(" & url & "),&:read).to_s")
  8.          y = ojs.eval("$r.map{|p|$s.scan(/#{p}"">([\s\S]*?)</)[0]}.flatten.map{|x|x.to_s.encode('gbk').gsub(/\s+/,'')}.map.with_index{|x,i|i<3?x[/[\d,]+/]:x}")
  9.          y1 = ojs.eval("$s.scan(/title>(.+?)(?=<)/)[0][0][0..-8].encode('gbk',{:invalid => :replace, :undef => :replace, :replace => '?'})")
  10.          cell(1, 2).Resize(1, 5) = y
  11.          cell(1, -1) = y1
  12.     Next
  13.     Set ojs = Nothing
  14.     Stop
  15. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2015-1-5 21:52 | 显示全部楼层
本帖最后由 bluexuemei 于 2015-1-6 14:41 编辑
  1. Sub 提取图片()
  2. Dim url$, bname$, img, cell As Range, ojs As Object
  3. Dim nUrl As String, localFilename As String
  4. Dim XmlHttp As Object, ayrHttpBody() As Byte
  5. Set XmlHttp = CreateObject("msxml2.xmlhttp")
  6. Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript"
  7. For Each cell In Selection
  8.     XmlHttp.Open "GET", cell.Value, False
  9.     XmlHttp.Send
  10.     s = XmlHttp.responsetext
  11.     bname = Split(Split(s, "</title>")(0), "<title>")(1)
  12.     bname = Mid(bname, 1, Len(bname) - 8)
  13.     bname = ojs.eval("'" & bname & "'.gsub(/\?/,'')")
  14.     If InStr(s, "<h3>商品画像</h3>") > 0 Then
  15.         s = Split(Split(s, "<h3>商品画像</h3>")(1), "商品説明")(0)
  16.         img = ojs.eval("'" & s & "'.scan(/<img src\=""(.+?.jpg)/).flatten")
  17.         subfolder = Trim(Replace(Replace(bname, "/", ""), Chr(63), "")) & Replace(Round(Rnd(), 3), ".", "")
  18.         MkDir ThisWorkbook.Path & "" & subfolder
  19.         For i = 0 To UBound(img)
  20.                 nUrl = img(i)
  21.                 localFilename = ThisWorkbook.Path & "" & subfolder & "" & i + 1 & ".jpg"
  22.                 XmlHttp.Open "GET", nUrl, True       '异步下载
  23.                 XmlHttp.Send
  24.                 Do Until XmlHttp.ReadyState = 4
  25.                     DoEvents
  26.                 Loop
  27.                 If XmlHttp.Status = 200 Then
  28.                    ayrHttpBody() = XmlHttp.responsebody
  29.                    Open localFilename For Binary As #1
  30.                    Put #1, , ayrHttpBody()
  31.                    Close #1
  32.                 End If
  33.         Next
  34.     End If
  35. Next
  36. Set ojs = Nothing
  37. Set XmlHttp = Nothing
  38. 'Stop
  39. End Sub
复制代码
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 22:38 , Processed in 0.050810 second(s), 12 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表