Sub クリップボードの画像を保存する()
Dim strSaveFilePath As String
Dim strCommand As String
Dim strImagePath As String
Dim strFileName As String
Dim strImageType As String
Dim objWsh As Object
Dim objClipboard As Variant
Dim intEndrow As Integer
Dim i As Integer
'Wscript.Shellをオブジェクトにセットします。
Set objWsh = CreateObject("WScript.Shell")
'マクロ実装ブックの１シート目を対象にします。
With ThisWorkbook.Worksheets(1)
'保存先パスを取得します。
strSaveFilePath = .Cells(1, 2)
'画像タイプを取得します。
strImageType = .Cells(2, 2)
'画像ファイル名を取得します。
strFileName = .Cells(3, 2)
'画像ファイルのフルパスを作成します。ファイル名が重複していた場合は別のファイル名に変換されます。
strImagePath = strSaveFilePath & "\" & fileNameDuplicateCheck(strSaveFilePath, strFileName & "." & strImageType)
'PowerShellの画像生成コマンドを作成します。
strCommand = "powershell "
strCommand = strCommand + "Add-Type -AssemblyName System.Windows.Forms;$ImagePath = '" & strImagePath & "'; [Windows.Forms.Clipboard]::GetImage().Save($ImagePath, [System.Drawing.Imaging.ImageFormat]::" & strImageType & ")"
End With
objClipboard = Application.ClipboardFormats
'クリップボードの内容を判定します。
If objClipboard(1) = -1 Then
MsgBox "クリップボードが空です。"
'クリップボードの内容がビットマップ形式か判定します。
ElseIf objClipboard(1) = xlClipboardFormatBitmap Then
'コマンドを実行します。
objWsh.Run Command:=strCommand, WindowStyle:=0, WaitOnReturn:=True
MsgBox "キャプチャ画像の保存が完了しました。"
Else
MsgBox "クリップボードが画像以外であるため中断します。"
End If
'オブジェクトを開放します。
Set objWsh = Nothing
Set objClipboard = Nothing
End Sub
'ファイル名重複チェック関数です。重複していたら別のファイル名を返します。
Function fileNameDuplicateCheck(fncPath As String, fncFileName As String)
Dim fnFullPath
Dim j As Integer
fncFullPath = fncPath & "\" & fncFileName
fncFileNameNext = fncFileName
'フルパスが存在しない場合のみファイルを書き出します。
If Dir(fncPath & "\" & fncFileName) <> "" Then
j = 1
'重複していたら保存ファイル名の先頭に(**)をつけます。
Do While Dir(fncPath & "\" & fncFileNameNext) <> ""
fncFileNameNext = "(" & j & ")" & fncFileName
j = j + 1
Loop
End If
'ファイル名を返します。
fileNameDuplicateCheck = fncFileNameNext
End Function
コメントを残す