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

怪盗KID

bluexuemei 发表于 2014-12-31 16:10
这个也不难，就是几行代码的问题

有才就是任性，这回答霸气外露。靠兄弟你了。

bluexuemei

1. Sub getwebdata()
   
2. '需要安装ACTIVERUBY ，下载地址 http://www.artonx.org/data/asr/Ruby-2.1.1.msi
   
3.     Dim url, info, bname, img, cell
   
4.     Dim nUrl As String, localFilename As String
   
5.     Dim XmlHttp As Object, ayrHttpBody() As Byte
   
6.     Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript"
   
7.     Set XmlHttp = CreateObject("Microsoft.XMLHTTP")
   
8.     For Each cell In Selection
   
9.          url = cell.Value
   
10.          y = ojs.eval("require 'open-uri';$s=open(%Q(" & url & "),&:read)")
    
11.          info = ojs.eval("r=Regexp.union('decTxtAucPrice,StartPrice,EndTime,SellerID'.split(','));$s.scan(/#{r}"">([\s\S]*?)</).flatten.insert(2,'').map{|x|x.encode('gbk').gsub(10.chr,'')}")
    
12.          bname = ojs.eval("$s.scan(/title>(.+?)(?=\-)/)[0][0].encode('gbk')")
    
13.          img = ojs.eval("$s.scan(/li title.+?src\=""(.+?)""/).flatten")
    
14.          cell(1, 2).Resize(1, 5) = info
    
15.          cell(1, -1).Value = bname
    
16.          subfolder = Replace(Replace(bname, "/", ""), " ", "")
    
17. '         Debug.Print subfolder
    
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.     Next
    
35.     Set XmlHttp = Nothing
    
36.     Set ojs = Nothing
    
37.     Columns("a:h").AutoFit
    
38.     Stop
    
39. End Sub

复制代码

怪盗KID

bluexuemei兄和各位路过的朋友新年快乐。

昨天忙于过节，今天才有空测试，想想自己的效率再想想bluexuemei兄的效率总是想着脸红，汗死。

言归正传说一下第二段程序测试结果。

总体来说完全实现了我的要求，使用起来不是一般的好用。无论图片有几张，甚至是没有图片，都不会产生错误。对比一下看看还需改进的地方，统统是我没有提过的要求，汗死。合着短板还在我这里。

改进需要：

1：从日雅读取文字和下载图片，我还是希望能分开为两个独立的程序。因为有的时候时间会提前结束，我需要不断更新文字部分，图片则无此必要，而且图片一旦重复，可能不太好处理。这点我之前没考虑到，并且说清楚，非常抱歉。

2：读取文字部分——执行程序后似乎列宽自动适应，希望取消此功能。个别列太宽我需要再调回来。

3：读取文字部分——价格方面有日元符号“円”，需要去掉，否则我没法很容易的计算数单的总价。有意思的是现在价格和成交价格还有细微差别，一个有空格，另一个没有。

4：读取文字部分——同样是价格方面要素，即决价格还是得麻烦你帮忙解决一下，我太高估我自己了，附上有即决价格的链接（附件中标注红色）。需要注意的是有的链接只有即决价格，没有现在的价格，还有的链接既有即决价格，也有现在价格，对应两种情况我都在附件中放出。

5：下载图片部分——我考虑了一下，还是有可能遇到两个链接，宝贝名称一致的情况，如遇这样情况，请程序自动设置第二个文件夹（放图片的文件夹）的名称后面加一个“-2”，“-3”，然后依次类推。

6：我之前下载过一段程序，可以在2013版本中，设置隐藏的图片类型的批注，这样即使不懂日语，看看隐藏的图片也很容易想起来这个链接是什么。出于一些考虑，这个也希望单独编写第3个独自程序实现（如果可能的话，希望直接使用对应网址的图片，而非程序2下载的图片）。附上我之前下载的程序源码供参考（之前我只会使用本地图片）。EXCEL中显示的图片长款比例希望希望和网上图片保持1:1。

Sub 添加图片批注()
Dim 单元格

On Error Resume Next

For Each 单元格 In Selection

单元格.AddComment

单元格.Comment.Shape.Fill.UserPicture "C:\Pictures\BB\" & 单元格.Value & ".jpg"

单元格.Comment.Shape.Height = 150

单元格.Comment.Shape.Width = 150

Next 单元格
End Sub

以上是目前的全部请求，希望能拜托bluexuemei兄，事成之后，还是30元话费做礼金吧。

怪盗KID

bluexuemei 发表于 2014-12-31 18:57

改进需求6：追加说明：设置第一张照片作为隐藏图片即可。

VBA万岁

bluexuemei 发表于 2014-12-31 18:57

今下载安装了ACTIVERUBY，测试楼上的代码情况如附件。
不知bluexuemei大侠肯否讲解一下ACTIVERUBY的用途？
自动抓取雅虎信息.zip (22.33 KB, 下载次数: 5)

2015-1-2 18:31 上传

点击文件名下载附件

bluexuemei

1. Sub getwebdata提取文本() '提取文本
   
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].split(//).select{|x|x.ord!=12539}.join.encode('gbk')")
   
10.          cell(1, 2).Resize(1, 5) = y
    
11.          cell(1, -1) = y1
    
12.     Next
    
13.     Set ojs = Nothing
    
14.     'Stop
    
15. End Sub

复制代码

VBA万岁

VBA万岁 发表于 2015-1-2 14:14
今下载安装了ACTIVERUBY，测试楼上的代码情况如附件。
不知bluexuemei大侠肯否讲解一下ACTIVERUBY的用途 ...

多谢bluexuemei 大侠指点，我去看看。

bluexuemei

1. SSub getwebpicture提取图片() '提取图片
   
2.    'http://www.artonx.org/data/asr/Ruby-2.1.1.msi
   
3.     Dim url, bname, img, cell
   
4.     Dim nUrl As String, localFilename As String
   
5.     Dim XmlHttp As Object, ayrHttpBody() As Byte
   
6.     Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript"
   
7.     Set XmlHttp = CreateObject("Microsoft.XMLHTTP")
   
8.     On Error Resume Next
   
9.     For Each cell In Selection
   
10.          url = cell.Value
    
11.          y = ojs.eval("require 'open-uri';$s=open(%Q(" & url & "),&:read)")
    
12.          bname = ojs.eval("$s.scan(/title>(.+?)(?=\-)/)[0][0].encode('gbk')")
    
13.          img = ojs.eval("$s.scan(/li title.+?src\=""(.+?)""/).flatten")
    
14.          subfolder = Trim(Replace(bname, "/", "")) & Round(Rnd(), 3)
    
15.          MkDir ThisWorkbook.Path & "" & subfolder
    
16.    
    
17.          For i = 0 To UBound(img)
    
18.             nUrl = img(i)
    
19.             localFilename = ThisWorkbook.Path & "" & subfolder & "" & i + 1 & ".jpg"
    
20.             XmlHttp.Open "GET", nUrl, True       '异步下载
    
21.             XmlHttp.Send
    
22.             Do Until XmlHttp.ReadyState = 4
    
23.                 DoEvents
    
24.             Loop
    
25.             If XmlHttp.Status = 200 Then
    
26.                ayrHttpBody() = XmlHttp.ResponseBody
    
27.                Open localFilename For Binary As #1
    
28.                Put #1, , ayrHttpBody()
    
29.                Close #1
    
30.             End If
    
31.          Next
    
32.     Next
    
33.     Set XmlHttp = Nothing
    
34.     Set ojs = Nothing
    
35.     'Stop
    
36. End Sub

复制代码

bluexuemei

1. Sub addcomment() '添加图片批注
   
2. '需要安装ACTIVERUBY ，下载地址 http://www.artonx.org/data/asr/Ruby-2.1.1.msi
   
3.     Dim url, bname, img, cell
   
4.     Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript"
   
5.     On Error Resume Next
   
6.     For Each cell In Selection
   
7.          url = cell.Value
   
8.          y = ojs.eval("require 'open-uri';$s=open(%Q(" & url & "),&:read)")
   
9.          img = ojs.eval("$s.scan(/<img src\=""(.+?.jpg)/)[0][0]")
   
10.          Debug.Print img
    
11.          With cell
    
12.            .addcomment
    
13.            .Comment.Shape.Fill.UserPicture img
    
14.          End With
    
15.    
    
16.     Next
    
17.     Set XmlHttp = Nothing
    
18.     Set ojs = Nothing
    
19.     Stop
    
20. End Sub

复制代码

怪盗KID

谢谢bluexuemei 兄，程序都已经测试过，问题如下：
提取文档程序
1，有的价格不正确，不知道为什么，已经在附件标注黄色。
2，有一个宝贝名称死活出不来，很奇怪。（附件倒数第二行）
3，第4行的名称为粗体字，原因是？
提取图片程序
最新的这版程序无法提取到图片，请检查。另外后面说是增加了随机数，但连随机数的位数也是随机的吗？看上去真是有些乱了，能不能限定一定的位数，比如三位应该就蛮够了。
添加批注程序
还是上面说的倒数第二行提取不到，
另外请帮我把批注的位置挪到每行的A列，显示在宝贝名称上好些。
最后要说的是批注图片尺寸的问题，小了些，看不清，感觉起码要比现在大一倍，最好看上去和我浏览日雅网页看到的差不多大小。

再次麻烦了。