[UMU WSH 教程](43) WIA 应用实例 - 批量转换图片格式

[UMU WSH 教程](42) FSO 应用实例 - 批量删除文件

UMU WSH 教程代码下载：http://sdrv.ms/ZpPPaS

UMU WSH Git：http://git.oschina.net/umu618/umu-wsh

　　bmp 格式的图片占空间比较大，转为无损压缩的 png 格式可以节省空间。下面利用 FSO 和 WIA 对象批量转换 bmp 文件为 png 格式。

 

' 43_bmp2png.VBS
' UMU @ 0:23 2012/10/14
' [UMU WSH 教程](43) WIA 应用实例 - 批量转换图片格式
Option Explicit

Const wiaFormatPNG = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
Const APP_TITLE = "UMU.Script.Tools.bmp2png"

Dim objArgs, objFSO


Set objArgs = WScript.Arguments
Set objFSO = CreateObject( "Scripting.FileSystemObject" )

If objArgs.Count = 0 Then
    Dim objWSH
    Dim szSendto, szCopyTo


    MsgBox "本程序用来把 bmp 格式图片转换为 png 格式。" & vbCrLf & _
        "请把要处理的文件或文件夹拖放到本程序的图标上！", _
        vbInformation, APP_TITLE

    Set objWSH = CreateObject( "WScript.Shell" )
    szSendto = objWSH.SpecialFolders("SendTo")
    szCopyTo = szSendto & "\bmp2png.VBE"

    If Not objFSO.FileExists(szCopyTo) Then
        If vbOK = MsgBox("本程序用来把 bmp 格式图片转换为 png 格式。" & vbCrLf & _
            "请把要处理的文件或文件夹拖放到本程序的图标上！" & vbCrLf & vbCrLf & _
            "提示：您可以把此文件放在 Sendto 目录里，然后使用右键菜单的“发送到”。" & vbCrLf & _
            "您的 Sendto 目录是 " & szSendto & vbCrLf & "按“确定”执行复制操作。", _
            vbOKCancel + vbInformation, APP_TITLE) Then
            
            objFSO.CopyFile WScript.ScriptFullName, szCopyTo

            If vbYes = MsgBox("是否查看 Sendto 目录？", vbQuestion + vbYesNo, APP_TITLE) Then
                objWSH.Run "%SystemRoot%\explorer.exe /n, /select," & szCopyTo
            End If
        End If
    End If

    Set objFSO = Nothing
    Set objWSH = Nothing
    Set objArgs = Nothing
    WScript.Quit
End If

Dim fDelete

fDelete = MsgBox( "转换后是否删除原 bmp 文件？", vbYesNoCancel + vbQuestion, "询问" )
If vbCancel = fDelete Then
    Set objArgs = Nothing
    WScript.Quit
End If

Dim ar, nSucceededCount, nFailedCount, nPngExistsCount


nSucceededCount = 0
nFailedCount = 0
nPngExistsCount = 0

For Each ar In objArgs
    If objFSO.FolderExists(ar) Then
        Call BmpToPng_s(ar)
    ElseIf objFSO.FileExists(ar) Then
        Call BmpToPng(ar)
    End If
Next

Set objArgs = Nothing
Set objFSO = Nothing

MsgBox "转换 bmp 文件 " & nSucceededCount & " 个，失败 " & nFailedCount & _
    " 个，PNG 文件已经存在 " & nPngExistsCount & " 个！", 4160, "整个世界清净了！"

Private Sub BmpToPng_s( ByVal szFolderPath )
    'On Error Resume Next


    Dim rfd, fs, f, fds, fd


    Set rfd = objFSO.GetFolder( szFolderPath )
    Set fs = rfd.Files
    For Each f In fs
        BmpToPng f.Path
    Next

    Set fds = rfd.SubFolders
    For Each fd In fds
        BmpToPng_s fd.Path
    Next
End Sub

Private Sub BmpToPng( ByVal szFilePath )
    On Error Resume Next


    Dim szExt, szPng


    szExt = Right( szFilePath, 4 )
    If StrComp( szExt, ".bmp", vbTextCompare ) Then
        Exit Sub
    End If

    szPng = Left(szFilePath, Len(szFilePath) - 4) & ".png"
    If objFSO.FileExists(szPng) Then
        nPngExistsCount = nPngExistsCount + 1
        Exit Sub
    End If

    Err.Clear

    Dim objIF, objIP


    Set objIF = CreateObject( "WIA.ImageFile" )
    Set objIP = CreateObject( "WIA.ImageProcess" )

    objIF.LoadFile szFilePath
    If Err.Number Then
        nFailedCount = nFailedCount + 1
        Exit Sub
    End If

    If objIF.FormatID <> wiaFormatPNG Then
        objIP.Filters.Add objIP.FilterInfos("Convert").FilterID
        objIP.Filters(1).Properties("FormatID").Value = wiaFormatPNG
        Set objIF = objIP.Apply(objIF)
        objIF.SaveFile szPng

        If Err.Number Then
            Set objIF = Nothing
            Set objIP = Nothing
            nFailedCount = nFailedCount + 1
            Exit Sub
        End If

        nSucceededCount = nSucceededCount + 1

        If vbYes = fDelete Then
            objFSO.DeleteFile szFilePath
        End If
    End If

    Set objIF = Nothing
    Set objIP = Nothing
End Sub

转载于:https://my.oschina.net/umu618/blog/82960