Board logo

标题: [技术讨论] VBS实现对网页滚动截图并发送到指定QQ窗口 [打印本页]

作者: batman    时间: 2011-8-27 21:33     标题: VBS实现对网页滚动截图并发送到指定QQ窗口

因为VBS的SENDKDYS方法不能发送截屏键,所以在网上找了段生成截屏程序的代码修改了并加入其中(见Data和CreateExe(Data)部分),故不敢标为原创,发于此请大家测试了。。。
  1. Dim Data, STREAM, FILE, WindowName, Url
  2. Data = "4D5A90000300000004000000FFFF0000B800000000000000400000000000000000000000000000000000000000000000000000000000000000000000C00000000E1FBA0E00B409CD21B8014CCD21546869732070726F6772616D2063616E6E6F742062652072756E20696E20444F53206D6F64652E0D0D0A2400000000000000450E6EDA016F0089016F0089016F0089016F0189006F008963701389026F0089E9700B89006F008952696368016F008900000000000000000000000000000000504500004C01010017E773460000000000000000E0000F010B01060000000000000400000000000080110000001000000010000000004000001000000002000004000000000000000400000000000000002000000002000000000000020000000000100000100000000010000010000000000000100000000000000000000000F012000028000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000100000080000000000000000000000000000000000000000000000000000002E646174610000003A030000001000000004000000020000000000000000000000000000400000C0000000000000000000000000000000000000000000000000000000000000000020130000000000004D657373616765426F784100476574436F6D6D616E644C696E6541006B657962645F6576656E74004578697450726F6365737300467265654C696272617279004C6F61644C6962726172794100000000757365723332000053637265656E4361746368204279205368696C7978000000B3C9B9A6BDABD7A5CDBCB1A3B4E6B5BDCFB5CDB3BCF4CCF9B0E5000000000000000000000000000083EC0C535556578B7C24208B473C03C78138504500000F858E0000008B48788B44392003CF03C7894C2418C7442420000000008B491885C9894C2414766C8B6C2424894424248A4D008BD181E2FF00000089542410EB048B5424108B008BCD8D343833C08A062BC275248A55002BF584D274178A51014133C08BDA8A040E81E3FF0000002BC374E7EB0485C074268B4C24208B4424248B5424144183C0043BCA894C24208944242472AD5F5E5D33C05B83C40CC38B4424188B5424208B48248B401C8D0C5133D2668B14398D0C908B043903C75F5E5D5B83C40CC39090909090558BEC81EC48010000535657B906000000BE781040008D7DBCF3A566A5A4B905000000BE601040008D7DD8A158104000F3A5668B0D5C1040008A155E10400066A58945F466894DF88855FAC745FC0000000064A1180000008945FC8B45FC68481040008B48308B510C8B420C8B088B118B721856E8A7FEFFFF683C104000568BF8E89AFEFFFF6830104000568945FCE88CFEFFFF83C4188945F08D45F450FFD78BD8682410400053E873FEFFFF8B3D0010400083C4086A006A006A006A2CFFD76A006A026A006A2CFFD7681410400056E84BFEFFFF8BD0B94000000033C08DBDB9FEFFFFC685B8FEFFFF0083C408F3AB66ABAAFFD28BF883C9FF33C08D95B8FEFFFFF2AEF7D12BF98BC18BF78BFAC1E902F3A58BC833C083E103F3A48DBDB8FEFFFF83C9FFF2AEF7D1498A8C0DB7FEFFFF80F973742180F953741C680810400053E8DAFDFFFF83C4088D4DD88D55BC6A4051526A00FFD053FF55FC6A00FF55F05F5E5B8BE55DC39090909090909090901813000000000000000000002E1300000010000000000000000000000000000000000000000000002013000000000000AA026B657962645F6576656E74005553455233322E646C6C0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
  3. FILE = "psc.exe"
  4. WindowName = "BatHome技术组" '你要发送的指定qq的窗口名请注意要确保已打开
  5. Url = "www.bathome.net" '你要截取的网页Url
  6. Set STREAM = CreateObject("ADODB.Stream")
  7. STREAM.Type = 1
  8. STREAM.Open
  9. STREAM.Write CreateExe(Data)
  10. STREAM.SaveToFile FILE, 2
  11. STREAM.Close
  12. Set STREAM = Nothing
  13. OpenWeb Url
  14. CreateObject("Scripting.FileSystemObject").DeleteFile FILE
  15. MsgBox "网页截取完毕"
  16. Function CreateExe(Data)
  17.   Dim XMLDOM, PIC
  18.   Set XMLDOM = CreateObject("Microsoft.XMLDOM")
  19.   XMLDOM.loadXML "<?xml version=""1.0""?>"
  20.   Set PIC = XMLDOM.createElement("pic")
  21.   PIC.dataType = "bin.hex"
  22.   PIC.nodeTypedValue = Data
  23.   CreateExe = PIC.nodeTypedValue
  24.   Set XMLDOM = Nothing
  25. End Function
  26. Function OpenWeb(Url)
  27.   Dim OIE, WebTitle, Height, MaxHeight, Count
  28.   Set OIE = WScript.CreateObject("internetexplorer.application","event_")
  29.   OIE.Navigate Url
  30.   OIE.Visible = True
  31.   Do Until OIE.ReadyState = 4 : WScript.Sleep 200 : Loop
  32.   Height = OIE.Document.ParentWindow.Screen.AvailHeight - 150
  33.   MaxHeight = OIE.Document.Body.ScrollHeight
  34.   Count = Int(MaxHeight/Height)
  35.   If Count * Height < MaxHeight Then Count = Count + 1
  36.   WebTitle = OIE.Document.getElementsByTagName("title")(0).innertext
  37.   For i = 1 To Count
  38.     If i <> 1 Then WScript.Sleep 10000
  39.     PringScreen WebTitle
  40.     OIE.Document.ParentWindow.Scrollby 0, Height
  41.   Next
  42.   OIE.Quit
  43.   Set OIE = Nothing
  44. End Function
  45. Function PringScreen(WebTitle)
  46.   Dim SHELL
  47.   Set SHELL = CreateObject("Wscript.Shell")
  48.   SHELL.Run FILE & " /s"
  49.   WScript.Sleep 500
  50.   SHELL.AppActivate WindowName
  51.   WScript.Sleep 200
  52.   SHELL.SendKeys "{Enter}"
  53.   WScript.Sleep 200
  54.   SHELL.SendKeys "^v"
  55.   WScript.Sleep 200
  56.   SHELL.SendKeys "^{Enter}"
  57.   WScript.Sleep 200
  58.   SHELL.AppActivate WebTitle
  59.   Set SHELL = Nothing
  60. End Function
复制代码

作者: plp626    时间: 2011-8-27 22:49

标题党,把题目改为 用手指实现对网页滚动截图 更吸引人
作者: batman    时间: 2011-8-27 23:48

回复 2# plp626
这也叫标题党了,呵呵。。。




欢迎光临 批处理之家 (http://bbs.bathome.net/) Powered by Discuz! 7.2