順次、選択、そして繰り返し

プログラミングのことやITのこと、たまに演劇のことも書きます。

画像貼り付けマクロ(自動でリサイズ)

前に作った画像貼り付けマクロが使いにくかったので
自動でリサイズするように改良。

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だったら元画像の半分になる。

f:id:sndstudy:20151124215628p:plain

上が1.00で下が0.50
f:id:sndstudy:20151124220703p:plain

入力フォームのソースコード

'初期設定
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

一応、変な値を入力するとエラーメッセージが表示される。
f:id:sndstudy:20151124220040p:plain
f:id:sndstudy:20151124220057p:plain

入力フォームを表示するソースコード

Sub 設定フォーム表示()

    settei.Show vbModeless

End Sub

正規表現グローバル変数に少々手こずった。
やはり、セミコロンを打たないのに違和感を感じる……。

参考にしたサイト
VBAで正規表現を使う (2/3):CodeZine(コードジン)
ユーザーフォームの表示、非表示 : 初心者のためのOffice講座-SupportingBlog1
標準モジュールとフォーム間のデータ受け渡し�T|Excelユーザーフォーム入門
エクセルVBAマクロ - ユーザフォーム - ラベル
ユーザーフォーム