【ExcelVBA】キャプチャ画像の自動貼り付けツール(ダウンロード有り)

画面キャプチャ(プリスク)して、エクセルでセル位置を指定して、画像を貼って、画像の大きさ調整して…

といった作業は、このVBAに処理させてムダ工数を削除しましょう！

 

困りごと

この記事で以下のことが解決します。

解消方法

VBAに貼付処理を行わせることで解消できます。

 

いやいやいや…分かるけど分からんわ！って感じですよね。

プログラム的な話でいうと、クリップボードを監視し画像を検知したらエクセルへ貼付を行います。

処理の概要図になります。

 

これだけの作業を自動化することで、手間と工数が確実に減ります！

画面や処理詳細

キャプチャ管理画面

貼付設定を変更できる画面があります。

 

各設定項目については以下をご覧ください。

ツール	設定項目名称	説明
フレーム	貼付方向	貼付の際の方向を決める
ラジオボタン	下方向	アクティブセルから下方向へ画像貼付
ラジオボタン	右方向	アクティブセルから右方向へ画像貼付
テキストボックス	貼付倍率	画像の貼付時の倍率
テキストボックス	画像間セル数	画像と画像の間のセル数
トグルボタン	キャプチャ開始	画像キャプチャの自動貼付が開始
トグルボタン	キャプチャ停止	画像キャプチャの自動貼付が停止

 

処理詳細(プログラム)

UserForm、Moduleで処理を分けています。

UserFormのプログラムは以下をご覧ください。

' 変数宣言の強制オプション
Option Explicit

' *** [規定]フォーム初期化イベント ***
Private Sub Userform_initialize()

	OBtn_Under.Value = True
	
	TBox_Magnify.Value = "100"
	Module1.g_capMagnify = TBox_Magnify.Value
	
	TBox_PicCellNum.Value = "1"
	Module1.g_capPicCellNum = TBox_PicCellNum.Value
	
	TBtn_CapStop.Enabled = False
	TBtn_CapStop.Value = True
	
End Sub

' *** [規定]フォーム閉じる前イベント ***
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
	' ×ボタンでも自動キャプチャ処理を止める
	Module1.StopAutoCap
End Sub

' *** キャプチャ開始ボタン押下イベント ***
Private Sub TBtn_CapStart_Click()

	Dim capMagnify As Integer
	Dim capPicCellNum As Integer
	
	Dim errMsg As String
	
	' Value変更のイベント回避
	If True = TBtn_CapStart.Enabled Then
		' --- 貼付方向 ---
		Module1.g_capDirect = CapDirect.Under
		
		If True = OBtn_Right.Value Then
			Module1.g_capDirect = CapDirect.Right
		End If
		
		' --- 貼付倍率 ---
		errMsg = Lbl_Magnify.Caption & "は 10 ～ 400 の間で設定してください"
		If True = IsNumeric(TBox_Magnify.Value) Then
			capMagnify = CInt(TBox_Magnify.Value)
			
			If 10 <= capMagnify And capMagnify <= 400 Then
				Module1.g_capMagnify = capMagnify
			Else
				GoTo ValErr
			End If
			
		Else
			GoTo ValErr
		End If
   
		' --- 画像間セル数 ---
		errMsg = Lbl_PicCellNum.Caption & "は、1 ～20 の間の整数で設定してください"
		If True = IsNumeric(TBox_PicCellNum.Value) Then
			capPicCellNum = CInt(TBox_PicCellNum.Value)
			
			If 1 <= capPicCellNum And capPicCellNum <= 20 Then
				Module1.g_capPicCellNum = capPicCellNum
			Else
				
				GoTo ValErr
			End If
			
		Else
			GoTo ValErr
		End If
		
		' 画面状態制御
		chgStateTools (False)
		chgStateBtn (True)
		' 自動キャプチャ実行
		Module1.RunAutoCap
	End If
	
	GoTo NormalEnd

ValErr:
	setValErr (errMsg)
NormalEnd:
End Sub

' *** キャプチャ停止ボタン押下イベント ***
Private Sub TBtn_CapStop_Click()
	' Value変更のイベント回避
	If True = TBtn_CapStop.Enabled Then
		' 画面状態制御
		chgStateTools (True)
		chgStateBtn (False)
		' 自動キャプチャ停止
		Module1.StopAutoCap
	End If

End Sub

' *** エラー時の処理 ***
Private Sub setValErr(ByVal errMsg As String)
	MsgBox errMsg, vbExclamation
	' Value変更のイベント回避
	TBtn_CapStart.Enabled = False
	' ボタン押下状態を戻す
	TBtn_CapStart.Value = False
	TBtn_CapStart.Enabled = True
End Sub

' *** ツールステータス変更 ***
Private Sub chgStateTools(ByVal EnaState As Boolean)
	OBtn_Under.Enabled = EnaState
	OBtn_Right.Enabled = EnaState
	TBox_Magnify.Enabled = EnaState
	TBox_PicCellNum.Enabled = EnaState
End Sub

' *** ボタンステータス変更 ***
Private Sub chgStateBtn(ByVal BtnState As Boolean)
	TBtn_CapStart.Value = BtnState
	TBtn_CapStart.Enabled = Not BtnState
	
	If True = BtnState Then
		TBtn_CapStart.BackColor = RGB(255, 0, 0)
	Else
		TBtn_CapStart.BackColor = TBtn_CapStop.BackColor
	End If
	
	TBtn_CapStop.Value = Not BtnState
	TBtn_CapStop.Enabled = BtnState
	
End Sub

 

Moduleのプログラムは以下をご覧ください。

' クリップボード関連のライブラリのロード
Declare Function OpenClipboard Lib "User32" (Optional ByVal hwnd As Long = 0) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function EmptyClipboard Lib "User32" () As Long

' 変数宣言の強制オプション
Option Explicit

' 貼付方向ステータス
Public Enum CapDirect
	Under = 1
	Right = 2
End Enum

Public g_capMagnify As Integer
Public g_capPicCellNum As Integer
Public g_capDirect As CapDirect

Private g_capWait As Double
Private g_capStop As Boolean

' *** [規定]Excel起動時イベント ***
Private Sub Auto_Open()
	' 1日をミリ秒(86400000)に換算し、待機するミリ秒を算出
	g_capWait = 800 / 86400000
	
	' フォーム表示
	ShowCapFrom
End Sub

' *** フォーム表示 ***
Public Sub ShowCapFrom()
	UF_CapManeger.Show vbModeless
End Sub

' *** 自動キャプチャ実行 ***
Public Sub RunAutoCap()

	Dim clipBoard As Variant
	Dim clipCount As Long
	Dim lastImg As Integer
	Dim imgLength As Double
	Dim moveCell As Integer
	
	OpenClipboard
	EmptyClipboard
	CloseClipboard
	
	g_capStop = False
	
	On Error GoTo RunErr

	Do While True
		' キャプチャ停止でループ抜け
		If True = g_capStop Then
			GoTo StopEnd
		End If
		
		clipBoard = Application.ClipboardFormats
		
		For clipCount = 1 To UBound(clipBoard)
			If clipBoard(clipCount) = xlClipboardFormatBitmap Then
				' キャプチャ処理待ち時間
				' ※処理待ち時間が無いとSnippingToolの矩形選択でエラーとなるため
				Application.Wait Now + g_capWait
				ActiveSheet.Paste
				 
				' 貼付された画像を選択し倍率変更
				lastImg = ActiveSheet.Shapes.Count
				ActiveSheet.Shapes(lastImg).Select
				If 100 <> g_capMagnify Then
					Selection.Height = Selection.Height * (g_capMagnify / 100)
				End If
				
				' 貼付方向の「下方向」と「右方向」で処理分岐
				If CapDirect.Under = g_capDirect Then
					imgLength = Selection.Height
					moveCell = (imgLength / ActiveCell.RowHeight) + g_capPicCellNum
					ActiveCell.Offset(moveCell, 0).Activate
				ElseIf CapDirect.Right = g_capDirect Then
					imgLength = Selection.Width
					moveCell = (imgLength / (ActiveCell.ColumnWidth * 6.5)) + g_capPicCellNum
					ActiveCell.Offset(0, moveCell).Activate
				End If
				
				OpenClipboard
				EmptyClipboard
				CloseClipboard
				
			End If
						  
		Next clipCount

		' Excelへ制御を戻す
		DoEvents
	Loop

RunErr:
	MsgBox "エラーが発生しました。" & vbCrLf & "エラー番号：" & Err.Number & vbCrLf & "エラー詳細：" & Err.Description, vbCritical
	
StopEnd:
End Sub

' *** 自動キャプチャ停止 ***
Public Sub StopAutoCap()
	g_capStop = True
End Sub

 

 

ツールのダウンロード

まぁ、ごたくどうでもはいいから早く使いたい！ですよね。

分かります。

 

お待たせしましました。以下でダウンロードしてください。

 

 

ちなみに、マクロは有効にしないと使用できないので、ご注意ください。

動作不備があれば、ご連絡お待ちしています。修正は暇があれば…

使用手順

ツールの使用手順は以下をご覧ください。(ツールにもシート：説明書があります)

 

 

参考URL

とても参考にさせていただきました。

パク…ではなくオマージュの改良版となります(汗)