VBS调用Photoshop批量生成缩略图的代码_VBS

模仿腾讯新闻页，给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

                  Set doc = app.Open(objFile.Path)

                  Set app.ActiveDocument = doc

                  ReSizeImg(doc)

                  doc.SaveAs NewDirectory & Split(objFile.Name, ".")(0) & ".gif", gifOpt, True, PsExtensionType_psLowercase

                  Call doc.Close(psDoNotSaveChanges)

                  Set doc = Nothing

            End If

      Next

      Set app = Nothing

End Function

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

比较了一下，gif缩略图体积最小，所以就gif缩略图。关于VBS调用Photoshop，在Photoshop的C:\Program Files\Adobe\Adobe Photoshop CS4\Scripting\Documents目录下是说明文档，C:\Program Files\Adobe\Adobe Photoshop CS4\Scripting\Sample Scripts目录下是示例代码。如果要生成png缩略图，可以参考文档修改脚本相应的代码即可：

Set pngOpt = CreateObject("Photoshop.PNGSaveOptions")

With pngOpt

.Interlaced = False

End With

开始打算是调用Set Jpeg = CreateObject("Persits.Jpeg")来生成缩略图，好处是不用加载庞大的Photoshop，生成缩略图速度很快，但比起Photoshop图片质量差了一些，就放弃了。

本来的打算是不保存原图，直接打开网路图片，然后直接生成缩略图到本地。虽然Photoshop可以打开网络图片，但在脚本里调用Photoshop打开网络图片就不行，只好先保存网络图片到本地，然后再生成缩略图。

其实Photoshop自带了图片批处理功能：

窗口->动作->创建新动作->在PS中打开所有你想做的图片->选择其中一张图片，调整大小，另存为gif格式->关闭你已做好的图片->停止播放/记录。
文件->自动->批处理->“动作”栏中选你刚刚新创建的动作名称->点“源”下面的“选择”选择你想要处理照片的文件夹->“目标”下面“选择”另外一个你想保存缩略图的文件夹->确定。就OK了！

但比起程序来，显然程序要灵活的多，而且很多批处理效果只能靠程序实现，所以没有通过录制动作来生成缩略图。

生成相应的图片格式代码，也可以在地址栏输入以下JS代码：

javascript:D=prompt("图片配字","");E=D.split(" ");A=document.getElementById("fontzoom");B=A.getElementsByTagName("img");C="0###";for(i=0;i<B.length;i++){if(i>0) C+="***";C=C+B[i].src+"@@@/small/"+B[i].src.substring(B[i].src.lastIndexOf("/")+1).replace("jpg","gif")+"@@@"+E[i];}window.prompt("复制",C);void(0);