【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個ずつ戻すボタンとかエラー処理はいくつか入れていますが割愛。

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

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

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

コメントを残す

メールアドレスが公開されることはありません。 が付いている欄は必須項目です

CAPTCHA