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

batman

因为VBS的SENDKDYS方法不能发送截屏键，所以在网上找了段生成截屏程序的代码修改了并加入其中（见Data和CreateExe(Data)部分），故不敢标为原创，发于此请大家测试了。。。

Dim Data, STREAM, FILE, WindowName, Url
Data = "4D5A90000300000004000000FFFF0000B800000000000000400000000000000000000000000000000000000000000000000000000000000000000000C00000000E1FBA0E00B409CD21B8014CCD21546869732070726F6772616D2063616E6E6F742062652072756E20696E20444F53206D6F64652E0D0D0A2400000000000000450E6EDA016F0089016F0089016F0089016F0189006F008963701389026F0089E9700B89006F008952696368016F008900000000000000000000000000000000504500004C01010017E773460000000000000000E0000F010B01060000000000000400000000000080110000001000000010000000004000001000000002000004000000000000000400000000000000002000000002000000000000020000000000100000100000000010000010000000000000100000000000000000000000F012000028000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000100000080000000000000000000000000000000000000000000000000000002E646174610000003A030000001000000004000000020000000000000000000000000000400000C0000000000000000000000000000000000000000000000000000000000000000020130000000000004D657373616765426F784100476574436F6D6D616E644C696E6541006B657962645F6576656E74004578697450726F6365737300467265654C696272617279004C6F61644C6962726172794100000000757365723332000053637265656E4361746368204279205368696C7978000000B3C9B9A6BDABD7A5CDBCB1A3B4E6B5BDCFB5CDB3BCF4CCF9B0E5000000000000000000000000000083EC0C535556578B7C24208B473C03C78138504500000F858E0000008B48788B44392003CF03C7894C2418C7442420000000008B491885C9894C2414766C8B6C2424894424248A4D008BD181E2FF00000089542410EB048B5424108B008BCD8D343833C08A062BC275248A55002BF584D274178A51014133C08BDA8A040E81E3FF0000002BC374E7EB0485C074268B4C24208B4424248B5424144183C0043BCA894C24208944242472AD5F5E5D33C05B83C40CC38B4424188B5424208B48248B401C8D0C5133D2668B14398D0C908B043903C75F5E5D5B83C40CC39090909090558BEC81EC48010000535657B906000000BE781040008D7DBCF3A566A5A4B905000000BE601040008D7DD8A158104000F3A5668B0D5C1040008A155E10400066A58945F466894DF88855FAC745FC0000000064A1180000008945FC8B45FC68481040008B48308B510C8B420C8B088B118B721856E8A7FEFFFF683C104000568BF8E89AFEFFFF6830104000568945FCE88CFEFFFF83C4188945F08D45F450FFD78BD8682410400053E873FEFFFF8B3D0010400083C4086A006A006A006A2CFFD76A006A026A006A2CFFD7681410400056E84BFEFFFF8BD0B94000000033C08DBDB9FEFFFFC685B8FEFFFF0083C408F3AB66ABAAFFD28BF883C9FF33C08D95B8FEFFFFF2AEF7D12BF98BC18BF78BFAC1E902F3A58BC833C083E103F3A48DBDB8FEFFFF83C9FFF2AEF7D1498A8C0DB7FEFFFF80F973742180F953741C680810400053E8DAFDFFFF83C4088D4DD88D55BC6A4051526A00FFD053FF55FC6A00FF55F05F5E5B8BE55DC39090909090909090901813000000000000000000002E1300000010000000000000000000000000000000000000000000002013000000000000AA026B657962645F6576656E74005553455233322E646C6C0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
FILE = "psc.exe"
WindowName = "BatHome技术组" '你要发送的指定qq的窗口名请注意要确保已打开
Url = "www.bathome.net" '你要截取的网页Url
Set STREAM = CreateObject("ADODB.Stream")
STREAM.Type = 1
STREAM.Open
STREAM.Write CreateExe(Data)
STREAM.SaveToFile FILE, 2
STREAM.Close
Set STREAM = Nothing
OpenWeb Url
CreateObject("Scripting.FileSystemObject").DeleteFile FILE
MsgBox "网页截取完毕"

Function CreateExe(Data)
  Dim XMLDOM, PIC
  Set XMLDOM = CreateObject("Microsoft.XMLDOM")
  XMLDOM.loadXML "<?xml version=""1.0""?>"
  Set PIC = XMLDOM.createElement("pic")
  PIC.dataType = "bin.hex"
  PIC.nodeTypedValue = Data
  CreateExe = PIC.nodeTypedValue
  Set XMLDOM = Nothing
End Function

Function OpenWeb(Url)
  Dim OIE, WebTitle, Height, MaxHeight, Count
  Set OIE = WScript.CreateObject("internetexplorer.application","event_")
  OIE.Navigate Url
  OIE.Visible = True
  Do Until OIE.ReadyState = 4 : WScript.Sleep 200 : Loop
  Height = OIE.Document.ParentWindow.Screen.AvailHeight - 150
  MaxHeight = OIE.Document.Body.ScrollHeight
  Count = Int(MaxHeight/Height)
  If Count * Height < MaxHeight Then Count = Count + 1
  WebTitle = OIE.Document.getElementsByTagName("title")(0).innertext
  For i = 1 To Count
    If i <> 1 Then WScript.Sleep 10000
    PringScreen WebTitle
    OIE.Document.ParentWindow.Scrollby 0, Height
  Next
  OIE.Quit
  Set OIE = Nothing
End Function

Function PringScreen(WebTitle)
  Dim SHELL
  Set SHELL = CreateObject("Wscript.Shell")
  SHELL.Run FILE & " /s"
  WScript.Sleep 500
  SHELL.AppActivate WindowName
  WScript.Sleep 200
  SHELL.SendKeys "{Enter}"
  WScript.Sleep 200
  SHELL.SendKeys "^v"
  WScript.Sleep 200
  SHELL.SendKeys "^{Enter}"
  WScript.Sleep 200
  SHELL.AppActivate WebTitle
  Set SHELL = Nothing
End Function
复制代码

batman

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

plp626

标题党，把题目改为 用手指实现对网页滚动截图 更吸引人