VBS调用Photoshop批量生成缩略图

模仿腾讯新闻页，给KingCms添加了新闻页图片点播的代码，代码要求的图片点播格式如下：

0###http://www.website.org/UploadFile/123.jpg@@@/small/123.gif@@@8标题一***http://www.website.org/UploadFile/456.jpg@@@/small/456.gif@@@标题二***http://www.website.org/UploadFile/789.jpg@@@/small/789.gif@@@标题三

格式解释如下：

0代表第0页出现图片点播；

http://www.website.org/UploadFile/123.jpg是第一幅原图地址。/small/123.gif是第一幅缩略图地址，原图和缩略图名字一样，后缀不一样，原图是jpg，缩略图是gif。标题一是第一幅图片的说明文字；

第二幅、第三幅图片格式和第一幅图一样；

###、@@@、***为相应的分隔符。

-------------------------------------------------分割线--------------------------------------------------------

开始我是用手工来写这些图片格式，发现效率很低，一下午只发布了两篇新闻，就编写了相应的VBS脚本。

脚本一：采集新闻图片，并生成相应的图片格式代码

Directory = "原始图"
Directory = CreateObject("Scripting.FileSystemObject").GetFolder(".").Path & "\" & Directory & "\"

Call DeleteFiles(Directory)

strUrl = InputBox("请输入网址：")
If strUrl <> "" Then
Call getImages(strUrl)
End If

Function getImages(strUrl)
     Set ie = WScript.CreateObject("InternetExplorer.Application")
     ie.visible = True
     ie.navigate strUrl
     Do
          Wscript.Sleep 500
     Loop Until ie.ReadyState=4
     Set objImgs = ie.document.getElementById("fontzoom").getElementsByTagName("img")

     strTitles = InputBox("请输入图片配字：")
     arrTitles = Split(strTitles, " ")
     strCode = "0###"

     For i=0 To objImgs.length - 1
          If i>0 Then strCode = strCode + "***"
          smallPic = Replace(Mid(objImgs(i).src, InStrRev(objImgs(i).src, "/")+1), "jpg", "gif")
          strCode = strCode + objImgs(i).src + "@@@/small/" + smallPic + "@@@" + arrTitles(i)
          SaveRemoteFile objImgs(i).src
     Next
     ie.Quit
     InputBox "请复制结果：", , strCode
End Function

Sub SaveRemoteFile(RemoteFileUrl)
     LocalFile = Directory & Mid(RemoteFileUrl, InStrRev(RemoteFileUrl, "/")+1)
     Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
     With xmlhttp
          .Open "Get", RemoteFileUrl, False, "", ""
          .Send
          GetRemoteData = .ResponseBody
     End With
     Set xmlhttp = Nothing
     Set Ads = CreateObject("Adodb.Stream")
     With Ads
          .Type = 1
          .Open
          .Write GetRemoteData
          .SaveToFile LocalFile, 2
          .Cancel()
          .Close()
     End With
     Set Ads=nothing
End Sub

Function DeleteFiles(strFolder)
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     Set objFolder = objFSO.GetFolder(strFolder)
     Set objFiles = objFolder.Files

     For Each objFile in objFiles
          objFile.Delete
     Next

Set objFSO = Nothing
End Function

脚本二：调用Photoshop批量生成缩略图

Directory = "原始图" '原始图像的文件夹
NewDirectory = "缩略图" '保存缩小图的文件夹

Const psDoNotSaveChanges = 2
Const PsExtensionType_psLowercase = 2
Const psDisplayNoDialogs = 3
Const psLocalSelective = 7
Const psBlackWhite = 2
Const psNoDither = 1

limitHeight = 58 '最大高度
ImgResolution = 72 '解析度

Call DeleteFiles(NewDirectory)
Call Convert2Gif(Directory)

Function ReSizeImg(doc)
      rsHeight = doc.height
      Scale = 1.0
      if rsHeight > limitHeight Then
            Scale = limitHeight / (doc.height + 0.0)
            rsWidth = doc.width * Scale
            rsHeight = doc.height * Scale
      End If
      doc.resizeImage rsWidth, rsHeight, ImgResolution, 3
End Function

Function Convert2Gif(Directory)
      Set app = CreateObject( "Photoshop.Application" )
      app.bringToFront()
      app.preferences.rulerUnits = 1 'psPixels
      app.DisplayDialogs = psDisplayNoDialogs

      Set gifOpt = CreateObject("Photoshop.GIFSaveOptions")
      With gifOpt
            .Palette = psLocalSelective
            .Colors = 256
            .Forced = psBlackWhite
            .Transparency = False
            .Dither = psNoDither
            .Interlaced = False
      End With

      Set fso = CreateObject("Scripting.FileSystemObject")
      If Not fso.FolderExists(Directory) Then
            MsgBox "Photo Directory NOT Exists."
            Exit Function
      End If

      Set objFiles = fso.GetFolder(Directory).Files
      NewDirectory = fso.GetFolder(".").Path & "\" & NewDirectory & "\"
      For Each objFile In objFiles
            If Split(objFile.Name, ".")(1) <> "db" Then

补充：综合编程 , 其他综合 ,