画像貼り付けマクロ(自動でリサイズ)
前に作った画像貼り付けマクロが使いにくかったので
自動でリサイズするように改良。
Option Explicit 'リサイズの割合 Public resize As Double '画像間のセルの行数 Public spaceRow As Integer Sub 画像貼り付けマクロ() Dim CB As Variant Dim i As Long Dim lastImg As Integer Dim imgHeight As Double Dim moveCell As Integer CB = Application.ClipboardFormats If CB(1) = True Then MsgBox "クリップボードは空です", 48 Exit Sub End If For i = 1 To UBound(CB) If CB(i) = xlClipboardFormatBitmap Then '画像貼り付け ActiveSheet.Paste '最後に貼った画像を選択 lastImg = ActiveSheet.Shapes.Count ActiveSheet.Shapes(lastImg).Select 'リサイズの値が0以外の時にリサイズを実行 If 0 <> resize Then 'リサイズ Selection.Height = Selection.Height * resize Selection.Width = Selection.Width End If '画像の高さを取得 imgHeight = Selection.Height If 0 <> resize Then 'セルの移動数を計算 moveCell = imgHeight \ ActiveCell.RowHeight + spaceRow Else 'セルの移動数を計算 moveCell = imgHeight \ ActiveCell.RowHeight + 2 End If 'セルの移動 ActiveCell.Offset(moveCell, 0).Activate Exit For End If Next i End Sub
そして、リサイズの値と画像間のセルの行数を設定できるように改良。
リサイズは1.00が原寸大で0.50だったら元画像の半分になる。
上が1.00で下が0.50
入力フォームのソースコード。
'初期設定 Private Sub UserForm_Initialize() 'テキストボックスに初期値を設定 Module1.resize = 1 Module1.spaceRow = 2 TextBox1.Value = "1.00" TextBox2.Value = Module1.spaceRow End Sub 'OKボタン押下時の処理 Private Sub okButton_Click() Dim re As RegExp Dim re2 As RegExp Set re = New RegExp Set re2 = New RegExp re.Pattern = "^[0-9]{1,1}\.[0-9]{1,2}$" re2.Pattern = "^[0-9]{1,1}$" '両方の値が正常値の場合 If re.Test(TextBox1.Value) = True And re2.Test(TextBox2.Value) = True Then Module1.resize = TextBox1.Value Module1.spaceRow = TextBox2.Value '非表示にする settei.Hide Else 'リサイズが異常値の場合 If re.Test(TextBox1.Value) = False Then MsgBox "リサイズは0.00~9.99の間で設定してください", 48 End If '行数が異常値の場合 If re2.Test(TextBox2.Value) = False Then MsgBox "行数はは0~9の間で設定してください", 48 End If End If End Sub
一応、変な値を入力するとエラーメッセージが表示される。
入力フォームを表示するソースコード。
Sub 設定フォーム表示() settei.Show vbModeless End Sub
正規表現やグローバル変数に少々手こずった。
やはり、セミコロンを打たないのに違和感を感じる……。
参考にしたサイト
VBAで正規表現を使う (2/3):CodeZine(コードジン)
ユーザーフォームの表示、非表示 : 初心者のためのOffice講座-SupportingBlog1
標準モジュールとフォーム間のデータ受け渡し�T|Excelユーザーフォーム入門
エクセルVBAマクロ - ユーザフォーム - ラベル
ユーザーフォーム