VBS調用Photoshop批量產生縮圖的代碼_vbs

模仿騰訊新聞頁，給KingCms添加了新聞頁圖片點播的代碼，代碼要求的圖片點播格式如下：

0###yun_qi_img/@@@/small/123.gif@@@8標題一***yun_qi_img/@@@/small/456.gif@@@標題二***yun_qi_img/@@@/small/789.gif@@@標題三

格式解釋如下：

0代表第0頁出現圖片點播；

yun_qi_img/是第一幅原圖地址。/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);