picsav23_batch.patch

diff -u -r org/modCommon.bas mine/modCommon.bas
--- org/modCommon.bas	Wed Jan 12 09:29:03 2011
+++ mine/modCommon.bas	Thu Feb 03 12:52:41 2011
@@ -150,7 +150,7 @@
 
 End Function
 
-Public Function SelectionCopyPicture(iFormat As Long) As Boolean
+Public Function SelectionCopyPicture(iFormat As Long, Optional vHideGridlines As Variant = Empty) As Boolean
     Dim bGridlines  As Boolean
     Dim iErr As Long
     Dim iRet As Long
@@ -172,8 +172,12 @@
     
     If TypeName(Selection) = "Range" Then
         If ActiveWindow.DisplayGridlines Then
-            iRet = MsgBox("セルの枠線を消去してコピーしますか?", vbQuestion Or vbYesNo, sAppName)
-            bGridlines = (iRet = vbYes)
+            If IsEmpty(vHideGridlines) Then
+                iRet = MsgBox("セルの枠線を消去してコピーしますか?", vbQuestion Or vbYesNo, sAppName)
+                bGridlines = (iRet = vbYes)
+            Else
+                bGridlines = CBool(vHideGridlines)
+            End If
         End If
     End If
     
@@ -206,12 +210,12 @@
 
 End Function
 
-Public Function CheckCopyPicture(iFormat As Long, sAppName As String) As Long
+Public Function CheckCopyPicture(iFormat As Long, sAppName As String, Optional vHideGridlines As Variant = Empty) As Long
     Dim iRet As Long
     
     CheckCopyPicture = 0
     
-    iRet = MsgBox("選択オブジェクトの画像をコピーしますか？", _
+    iRet = MyMsgBox("選択オブジェクトの画像をコピーしますか？", _
         vbExclamation Or vbYesNoCancel, sAppName)
     If iRet = vbCancel Then
         Exit Function
@@ -238,7 +242,7 @@
             End If
         End If
 
-        If Not SelectionCopyPicture(iFormat) Then
+        If Not SelectionCopyPicture(iFormat, vHideGridlines) Then
             MsgBox "選択オブジェクトの画像コピーに失敗しました。", vbExclamation, sAppName
             Exit Function
         End If
@@ -338,5 +342,28 @@
     MsgBox "エラーが発生しました。", vbExclamation, sAppName
     Exit Function
 
+End Function
+
+' バッチ処理時はポップアップしない MsgBox
+'
+' Application.DisplayAlerts = False の場合は [OK] や [はい] が押下されたようにふるまう
+Public Function MyMsgBox(prompt, Optional buttons = 0, Optional title = Empty, Optional helpfile = Empty, Optional context = Empty) As Integer
+    If Application.DisplayAlerts Then
+        MyMsgBox = MsgBox(prompt, buttons, title, helpfile, context)
+    Else
+        Dim iButtonType As Integer
+        iButtonType = buttons And 15
+        If iButtonType = vbOKOnly Or iButtonType = vbOKCancel Then
+            MyMsgBox = vbOK
+        ElseIf iButtonType = vbYesNoCancel Or iButtonType = vbYesNo Then
+            MyMsgBox = vbYes
+        ElseIf iButtonType = vbRetryCancel Then       ' [再試行] ボタンと [キャンセル] ボタン→無限ループ抑止のためキャンセル
+            MyMsgBox = vbCancel
+        ElseIf iButtonType = vbAbortRetryIgnore Then  ' [中止]、[再試行]、および [無視]→念のため中止
+            MyMsgBox = vbAbort
+        Else
+            MyMsgBox = vbCancel
+        End If
+    End If
 End Function
 
diff -u -r org/modMain.bas mine/modMain.bas
--- org/modMain.bas	Wed Jan 12 09:29:12 2011
+++ mine/modMain.bas	Thu Feb 03 12:52:41 2011
@@ -2,8 +2,10 @@
 Option Explicit
 
 Public Sub SaveBitmap()
-Attribute SaveBitmap.VB_ProcData.VB_Invoke_Func = " \n14"
-    Dim vFileName As Variant
+    SaveBitmapEx
+End Sub
+
+Public Function SaveBitmapEx(Optional vFileName As Variant = Empty, Optional vHideGridlines As Variant = Empty) As Boolean
     Dim sFileFilter As String
     Dim sFilterName As String
     Dim sFileType As String
@@ -12,13 +14,15 @@
     
     On Error GoTo ErrorHandler
     
+    SaveBitmapEx = False
+    
     If Not VersionCheck(7) Then
-        Exit Sub
+        Exit Function
     End If
-    
+        
     sfVersion = MyVal(Application.Version)
-    If CheckCopyPicture(xlBitmap, sAppName) = 0 Then
-        Exit Sub
+    If CheckCopyPicture(xlBitmap, sAppName, vHideGridlines) = 0 Then
+        Exit Function
     End If
    
     If sfVersion < 8 Then
@@ -32,14 +36,16 @@
             "すべてのファイル (*.*),*.*", vbNarrow)
     End If
     
-    vFileName = Application.GetSaveAsFilename( _
-        InitialFilename:="", FileFilter:=sFileFilter, Title:=sAppName)
-    If VarType(vFileName) = vbBoolean Then Exit Sub
-    
-    If Dir$(vFileName) <> "" Then
-        iRet = MsgBox("ファイルは既に存在します。上書きしますか？", _
-            vbExclamation Or vbOKCancel Or vbDefaultButton2, sAppName)
-        If iRet <> vbOK Then Exit Sub
+    If IsEmpty(vFileName) Then
+        vFileName = Application.GetSaveAsFilename( _
+            InitialFilename:="", FileFilter:=sFileFilter, title:=sAppName)
+        If VarType(vFileName) = vbBoolean Then Exit Function
+        
+        If Dir$(vFileName) <> "" Then
+            iRet = MyMsgBox("ファイルは既に存在します。上書きしますか？", _
+                vbExclamation Or vbOKCancel Or vbDefaultButton2, sAppName)
+            If iRet <> vbOK Then Exit Function
+        End If
     End If
     
     sFileType = UCase(Right$(vFileName, 4))
@@ -60,15 +66,15 @@
         Case Else
             sFilterName = ""
             GoTo SUB_SAVEGIF
-            Exit Sub
+            Exit Function
     End Select
-    Exit Sub
+    Exit Function
 
 SUB_SAVEBMP:
     If Not IsClipboardFormat(CF_DIB) Then
         MsgBox "クリップボードにビットマップ(DIB)がありません。", _
             vbExclamation, sAppName
-        Exit Sub
+        Exit Function
     End If
     
     MAX_BMP_SIZE = 0
@@ -78,7 +84,8 @@
     iRet = SaveClipboardDIB(vFileName)
     Select Case iRet
         Case 0
-            MsgBox "ビットマップを保存しました。", vbInformation, sAppName
+            MyMsgBox "ビットマップを保存しました。", vbInformation, sAppName
+            SaveBitmapEx = True
         Case 2
             MsgBox "24ビットから8ビットへの変換ができませんでした。", vbExclamation, sAppName
         Case 3
@@ -86,12 +93,12 @@
         Case Else
             MsgBox "エラーが発生しました。", vbExclamation, sAppName
     End Select
-    Exit Sub
+    Exit Function
 
 SUB_SAVEGIF:
     If sfVersion < 9 Then
         MsgBox "このバージョンでは動作しません。", vbExclamation, sAppName
-        Exit Sub
+        Exit Function
     End If
     
     iRet = SaveClipboardGIF(vFileName, sFilterName)
@@ -99,47 +106,54 @@
     Application.ScreenUpdating = True
     Select Case iRet
         Case 0
-            MsgBox "ビットマップを保存しました。", vbInformation, sAppName
+            MyMsgBox "ビットマップを保存しました。", vbInformation, sAppName
+            SaveBitmapEx = True
         Case Else
             MsgBox "エラーが発生しました。", vbExclamation, sAppName
     End Select
-    Exit Sub
+    Exit Function
 
 ErrorHandler:
     MsgBox Error(Err) & " (" & Err & ")", vbExclamation, sAppName
-    Exit Sub
-
-End Sub
+    Exit Function
 
+End Function
 
 Public Sub SavePicture()
-Attribute SavePicture.VB_ProcData.VB_Invoke_Func = " \n14"
-    Dim vFileName As Variant
+    SavePictureEx
+End Sub
+
+Public Function SavePictureEx(Optional vFileName As Variant = Empty, Optional vHideGridlines As Variant = Empty) As Boolean
+Attribute SavePictureEx.VB_ProcData.VB_Invoke_Func = " \n14"
     Dim sFileFilter As String
     Dim sFileType As String
     Dim iRet As Long
     
     On Error GoTo ErrorHandler
     
+    SavePictureEx = False
+    
     If Not VersionCheck(7) Then
-        Exit Sub
+        Exit Function
     End If
     
-    If CheckCopyPicture(xlPicture, sAppName) = 0 Then
-        Exit Sub
+    If CheckCopyPicture(xlPicture, sAppName, vHideGridlines) = 0 Then
+        Exit Function
     End If
     
-    vFileName = Application.GetSaveAsFilename( _
-        InitialFilename:="", _
-        FileFilter:=StrConv("Windows メタファイル (*.wmf),*.wmf," & _
-        "エンハンスト メタファイル (*.emf),*.emf," & _
-        "すべてのファイル (*.*),*.*", vbNarrow), Title:=sAppName)
-    If VarType(vFileName) = vbBoolean Then Exit Sub
-    
-    If Dir$(vFileName) <> "" Then
-        iRet = MsgBox("ファイルは既に存在します。上書きしますか？", _
-            vbExclamation Or vbOKCancel Or vbDefaultButton2, sAppName)
-        If iRet <> vbOK Then Exit Sub
+    If IsEmpty(vFileName) Then
+        vFileName = Application.GetSaveAsFilename( _
+            InitialFilename:="", _
+            FileFilter:=StrConv("Windows メタファイル (*.wmf),*.wmf," & _
+            "エンハンスト メタファイル (*.emf),*.emf," & _
+            "すべてのファイル (*.*),*.*", vbNarrow), title:=sAppName)
+        If VarType(vFileName) = vbBoolean Then Exit Function
+        
+        If Dir$(vFileName) <> "" Then
+            iRet = MyMsgBox("ファイルは既に存在します。上書きしますか？", _
+                vbExclamation Or vbOKCancel Or vbDefaultButton2, sAppName)
+            If iRet <> vbOK Then Exit Function
+        End If
     End If
     
     sFileType = UCase(Right$(vFileName, 4))
@@ -150,48 +164,49 @@
             GoTo SUB_SAVEEMF
         Case Else
             MsgBox "ファイル名が不正です。", vbExclamation, sAppName
-            Exit Sub
+            Exit Function
     End Select
     
-    Exit Sub
+    Exit Function
 
 SUB_SAVEWMF:
     If Not IsClipboardFormat(CF_METAFILEPICT) Then
         MsgBox "クリップボードにピクチャがありません。", _
             vbExclamation, sAppName
-        Exit Sub
+        Exit Function
     End If
 
     iRet = SaveClipboardMetaFile(vFileName)
     If iRet = 0 Then
-        MsgBox "ピクチャを保存しました。", vbInformation, sAppName
+        MyMsgBox "ピクチャを保存しました。", vbInformation, sAppName
+        SavePictureEx = True
     Else
         MsgBox "エラーが発生しました。", vbExclamation, sAppName
     End If
     
-    Exit Sub
+    Exit Function
 
 SUB_SAVEEMF:
     If Not IsClipboardFormat(CF_ENHMETAFILE) Then
         MsgBox "クリップボードにピクチャがありません。", _
             vbExclamation, sAppName
-        Exit Sub
+        Exit Function
     End If
     
     iRet = SaveClipboardEMF(vFileName)
     If iRet = 0 Then
-        MsgBox "ピクチャを保存しました。", vbInformation, sAppName
+        MyMsgBox "ピクチャを保存しました。", vbInformation, sAppName
+        SavePictureEx = True
     Else
         MsgBox "エラーが発生しました。", vbExclamation, sAppName
     End If
     
-    Exit Sub
+    Exit Function
 
 ErrorHandler:
     
     MsgBox Error(Err) & " (" & Err & ")", vbExclamation, sAppName
     
-    Exit Sub
-
-End Sub
+    Exit Function
 
+End Function