Skip to content

Instantly share code, notes, and snippets.

@miau

miau/picsav23_batch.patch

Created February 3, 2011 04:06
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save miau/809035 to your computer and use it in GitHub Desktop.
Save miau/809035 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment