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

bluexuemei

1. Sub 添加图片批注()
   
2. Dim doc, XmlHttp, ojs, s, img
   
3. Set XmlHttp = CreateObject("msxml2.xmlhttp")
   
4. Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript"
   
5. For Each cell In Selection
   
6.     XmlHttp.Open "GET", cell.Value, False
   
7.     XmlHttp.Send
   
8.     s = XmlHttp.responsetext
   
9.     If InStr(s, "<h3>商品画像</h3>") > 0 Then
   
10.       s = Split(Split(s, "<h3>商品画像</h3>")(1), "商品説明")(0)
    
11.       w = ojs.eval("'" & s & "'.scan(/<img src.+width=""(\d+)""/)[0][0].to_i")
    
12.       h = ojs.eval("'" & s & "'.scan(/<img src.+height=""(\d+)""/)[0][0].to_i")
    
13.       img = ojs.eval("'" & s & "'.scan(/<img src\=""(.+?.jpg)/)[0][0]")
    
14.       With cell(1, -1)
    
15.                .ClearComments
    
16.                .AddComment
    
17.                .Comment.Shape.Fill.UserPicture img
    
18.                .Comment.Shape.Height = h
    
19.                .Comment.Shape.Width = w
    
20.       End With
    
21.     End If
    
22. Next
    
23. Set ojs = Nothing
    
24. Set XmlHttp = Nothing
    
25. Stop
    
26. End Sub

复制代码

怪盗KID

bluexuemei 发表于 2015-1-5 21:53

之前三个程序已测试没问题。还有个需求希望朋友继续跟进。

现在考虑每页的商品具体介绍也想保存下来。考虑到有时内容较多，不适合保存在单元格中。又因为介绍当中有文字也可能会有图片。因此希望对每个链接做一个WORD文档进行保存。

文档放在程序2——提取照片创立的文件夹中较合适，即与图片文件并列。

注意程序2目前对于没有照片的情况不建立空文件夹。