【VBA】シェイプでナンバリング

図面にナンバリングするという作業を効率化する為にエクセルVBAを使用。
エクセルに挿入した図面にサクサク番号を付けていくことが出来る。

▼参考例

ポイントだけ下記に記す。

番号を作成

楕円や丸やフォントなど好きなように番号の連番を作成する。

Sub 連番シェイプ作成()
​
    Dim p1 As Single            '左位置
    Dim p2 As Single            '上位置
    Dim s1 As Single: s1 = 20   '横幅
    Dim s2 As Single: s2 = 12   '縦幅
    
    Dim r As Long, c As Long, i As Long
    
    i = 1
    For c = 1 To 5
        For r = 1 To 50
            p1 = Range("A1").Offset(r, c).Left
            p2 = Range("A1").Offset(r, c).Top
            ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, p1, p2, s1, s2).Name = "楕円" & i 'シェイプの名前
            With ActiveSheet.Shapes("楕円" & i)
                .Line.ForeColor.RGB = RGB(255, 0, 0) '線の色：赤
                .Line.Weight = 0.8 '線の太さ
                .Fill.Visible = msoFalse '塗りつぶし無し
                .Adjustments.Item(1) = 6 '角R
                With .TextFrame
                    .Characters.Text = i 'テキスト
                    .Characters.Font.size = 10 'フォントサイズ
                    .VerticalAlignment = xlVAlignCenter 'テキスト中央配置（垂直方向）
                    .HorizontalAlignment = xlHAlignCenter 'テキスト中央配置（水平方向）
                    .HorizontalOverflow = xlOartHorizontalOverflowOverflow 'はみ出して表示
                    .VerticalOverflow = xlOartHorizontalOverflowOverflow 'はみ出して表示
                    .MarginLeft = 0 '左余白
                    .MarginRight = 0 '右余白
                    .MarginTop = 0 '上余白
                    .MarginBottom = 0 '下余白
                    .Characters.Font.Bold = True '太字
                End With
                With .TextFrame2
                    .TextRange.Font.Fill.ForeColor.RGB = rgbBlack '黒色
                    .TextRange.Characters.Font.Spacing = -0.5 '文字間隔を詰める
                    .TextRange.Font.Name = Range("A1").Font.Name '英語フォント設定
                    .WordWrap = msoFalse '図形内でテキストを折り返さない
                End With
            End With
            DoEvents
            i = i + 1
        Next r
    Next c
    
End Sub

番号を呼び出す

今回は事前に上で作成しておいたものを呼び出すだけにした。 作成と呼び出しをセットにしておけば事前に作成しておかなくても可能。

Sub 番号呼び出し(shpNo As Long)
      
    Application.ScreenUpdating = False
          
    'サイズ変更
    Dim size As Long
    Select Case Range("サイズ").Value
        Case 0.3
            size = 9
        Case 0.35
            size = 10
        Case 0.4
            size = 11
        Case 0.45
            size = 13
        Case 0.5
            size = 14
        Case 0.55
            size = 16
    End Select
​
    Sheets("番号").Shapes("d" & shpNo).Copy
    Sheets("図面").Activate
    ActiveSheet.Paste
    
    'サイズ変更とシェイプにマクロ設定
    With Selection
        .Height = size
        .OnAction = "番号クリック"
    End With
               
    Range("A1").Select
    
    Application.ScreenUpdating = True
     
End Sub

番号をマウス位置に移動する

実際使うときはボタンクリックよりもショートカットキーを登録して使う。 頻繁に押すので「Ctrl+Z」にしている。

Sub 呼び出しボタンクリック()
​
    'マウス追従実行中は呼び出せないようにする
    If stop判定 = False Then Exit Sub
    
    '呼び出すNo.
    Dim shpNo As Long
    shpNo = Range("番号")
​
    Call 番号呼び出し(shpNo)
    Call マウス追従(shpNo)
​
End Sub

この下のループでマウス先端にくっついて動く。 DoEventsを二つ入れないとカクカクしてしまう。

Private stop判定 As Boolean
​
Private Sub マウス追従(shpNo As Long)
        
    Dim shp As Shape
    Set shp = ActiveSheet.Shapes("d" & shpNo)
        
    stop判定 = False
    
    Dim XY As TP_XY
    
    Do While stop判定 = False
    
        'ドキュメント座標起動
        XY = GetXYDocumentFromCursor(True)
        
        '4行目より上には移動しない
        If XY.Y > Range("A4").Top Then
            With shp
                .Left = XY.X - .Width / 2
                .Top = XY.Y - .Height / 2
            End With
        End If
        
        DoEvents
        DoEvents
                
    Loop
​
End Sub

番号を回転させる

ボタンクリックでの実行に加えてショートカットキーも登録している。 マウス追従中に縦横に回転させることが出来る。

Sub 回転()
    
'対象シェイプがなかったら何も起きない
On Error GoTo Jump
    
    '横だったら縦に、縦だったら横にする
    With ActiveSheet.Shapes("d" & Range("番号").Value)
        If .Rotation = 0 Then
            .Rotation = -90
        Else
            .Rotation = 0
        End If
    End With
    Exit Sub
    
Jump:
​
End Sub

番号を設置する

番号呼び出し時にシェイプに設定したマクロでクリック時に実行。

stop判定をTrueにしてマウス追従を止めることにより設置。 ついでにOnActionを無しにしてシェイプへのマクロ登録も解除している。

Sub 番号クリック()
​
    stop判定 = True
    shp.OnAction = ""
​
End Sub

その他

実際はほかにも１個ずつ戻すボタンとかエラー処理はいくつか入れていますが割愛。

• 1手キャンセルボタン
• 画像のグループ化ボタン
• 番号のみ全削除ボタン

参考にさせていただいたサイト

マウス位置のドキュメント座標はこちらのサイトのコードを使わせていただいています。
こちらが無ければできませんでした。