グリッドのズレをVBAで一発補正！選択シェイプをグリッドにピタッと吸着させる方法

昔作った図面がズレたままで気持ち悪いんだよね…

そんな時はVBAで一発補正！選んで実行するだけでピタッと揃うよ！

前回の記事ではグリッドの便利な使い方・・・プラス「ちょっと惜しいところ」をお伝えしました。今回はその解決策です！VBAを使って、ズレたシェイプをグリッドにガツンと吸着させる方法をご紹介します。

さらに「グリッドを固定値に一発設定」「スナップのON/OFF切り替え」のおまけコードもついてくるので、ぜひ最後まで読んでみてください！

【前回の記事】

選択シェイプをグリッドに補正するマクロ
コードの解説
おまけ①：グリッドを固定値に一発設定
おまけ②：スナップのON/OFF切り替え
まとめ

選択シェイプをグリッドに補正するマクロ

これが選択シェイプをグリッドにピタッと吸着させるマクロだよ！

まず補正したいシェイプを選択してから、マクロを実行してください。

動作のポイント：

グリッドが「固定」設定ならそのまま間隔を読み取って補正
グリッドが「自動」設定なら間隔をInputBoxで入力して補正
「サイズを合わせますか？」→ はい：幅・高さをグリッドに合わせる
「位置を合わせますか？」→ はい：左上をグリッドにピタッと合わせる
コネクタ（線）は自動でスキップ！接続が崩れる心配なし

サイズと位置、それぞれON/OFFを選べるから、どちらか一方だけの補正もOKだよ！

' ===== メイン =====
Sub SnapSelectedShapesToGrid()

    Dim objPage As Visio.Page
    Dim objSelection As Visio.Selection
    Dim shp As Visio.Shape
    Dim dblGridX As Double
    Dim dblGridY As Double
    Dim dblOriginX As Double
    Dim dblOriginY As Double
    Dim intSkipped As Integer
    Dim intFixed As Integer
    
    Set objPage = ActivePage
    Set objSelection = ActiveWindow.Selection
    
    ' 選択チェック
    If objSelection.Count = 0 Then
        MsgBox "シェイプを選択してから実行してください。", vbExclamation
        Exit Sub
    End If
    
    ' グリッド間隔を取得
    Dim intDensX As Integer
    Dim intDensY As Integer
    intDensX = objPage.PageSheet.CellsU("XGridDensity").ResultIU
    intDensY = objPage.PageSheet.CellsU("YGridDensity").ResultIU
    
    If intDensX = 0 And intDensY = 0 Then
        ' 固定の場合はそのまま読み出し
        dblGridX = objPage.PageSheet.CellsU("XGridSpacing").Result("in")
        dblGridY = objPage.PageSheet.CellsU("YGridSpacing").Result("in")
    Else
        ' 自動の場合はInputBoxで入力を促す
        Dim strInput As String
        strInput = InputBox("グリッド間隔が「自動」に設定されています。" & vbCrLf & _
                           "グリッド間隔をmmで入力してください（例：8）", "グリッド間隔", "8")
        If strInput = "" Then
            MsgBox "処理を中止しました。", vbInformation
            Exit Sub
        End If
        dblGridX = CDbl(strInput) / 25.4
        dblGridY = dblGridX
    End If
    
    ' グリッド線の開始位置を取得
    dblOriginX = objPage.PageSheet.CellsU("XGridOrigin").Result("in")
    dblOriginY = objPage.PageSheet.CellsU("YGridOrigin").Result("in")
    
    ' サイズ変更確認
    Dim blnResize As Boolean
    blnResize = False
    If MsgBox("サイズをグリッドに合わせますか？", vbYesNo + vbQuestion) = vbYes Then
        blnResize = True
    End If
    
    ' 位置合わせ確認
    Dim blnSnap As Boolean
    blnSnap = False
    If MsgBox("位置をグリッドに合わせますか？", vbYesNo + vbQuestion) = vbYes Then
        blnSnap = True
    End If
    
    ' 両方いいえなら終了
    If Not blnResize And Not blnSnap Then
        MsgBox "処理を中止しました。", vbInformation
        Exit Sub
    End If
    
    intSkipped = 0
    intFixed = 0
    
    ' 選択シェイプをループ
    For Each shp In objSelection
    
        If shp.OneD Then
            intSkipped = intSkipped + 1
        Else
            ' ① サイズ変更（先に実行）
            If blnResize Then
                Call ResizeToGrid(shp, dblGridX, dblGridY)
            End If
            
            ' ② 位置合わせ（サイズ確定後に実行）
            If blnSnap Then
                Call SnapToGrid(shp, dblGridX, dblGridY, dblOriginX, dblOriginY)
            End If
            
            intFixed = intFixed + 1
        End If
    Next shp
    
    ' 結果メッセージ
    Dim strMsg As String
    strMsg = intFixed & " 個のシェイプを処理しました。"
    If intSkipped > 0 Then
        strMsg = strMsg & vbCrLf & intSkipped & " 個のコネクタはスキップしました。"
    End If
    MsgBox strMsg, vbInformation

End Sub


' ===== サイズ変更 =====
Sub ResizeToGrid(shp As Visio.Shape, dblGridX As Double, dblGridY As Double)

    Dim dblLocPinX As Double
    Dim dblLocPinY As Double
    Dim dblWidth As Double
    Dim dblHeight As Double
    Dim dblLeft As Double
    Dim dblTop As Double
    
    ' サイズ変更前の左上を記録
    dblLocPinX = shp.CellsU("LocPinX").Result("in")
    dblLocPinY = shp.CellsU("LocPinY").Result("in")
    dblWidth = shp.CellsU("Width").Result("in")
    dblHeight = shp.CellsU("Height").Result("in")
    dblLeft = shp.CellsU("PinX").Result("in") - dblLocPinX
    dblTop = shp.CellsU("PinY").Result("in") + (dblHeight - dblLocPinY)
    
    ' サイズをグリッドに合わせる
    dblWidth = Round(dblWidth / dblGridX) * dblGridX
    dblHeight = Round(dblHeight / dblGridY) * dblGridY
    
    ' 最小1グリッド分は確保
    If dblWidth < dblGridX Then dblWidth = dblGridX
    If dblHeight < dblGridY Then dblHeight = dblGridY
    
    ' サイズ変更
    shp.CellsU("Width").FormulaForce = dblWidth & " in"
    shp.CellsU("Height").FormulaForce = dblHeight & " in"
    
    ' サイズ変更後のLocPinXYを再取得（幅の50%なので変わっている）
    dblLocPinX = shp.CellsU("LocPinX").Result("in")
    dblLocPinY = shp.CellsU("LocPinY").Result("in")
    
    ' 左上基準でPinXYを戻す
    shp.CellsU("PinX").FormulaForce = (dblLeft + dblLocPinX) & " in"
    shp.CellsU("PinY").FormulaForce = (dblTop - (dblHeight - dblLocPinY)) & " in"

End Sub


' ===== 位置合わせ =====
Sub SnapToGrid(shp As Visio.Shape, dblGridX As Double, dblGridY As Double, _
               dblOriginX As Double, dblOriginY As Double)

    Dim dblLocPinX As Double
    Dim dblLocPinY As Double
    Dim dblHeight As Double
    Dim dblLeft As Double
    Dim dblTop As Double
    
    dblLocPinX = shp.CellsU("LocPinX").Result("in")
    dblLocPinY = shp.CellsU("LocPinY").Result("in")
    dblHeight = shp.CellsU("Height").Result("in")
    
    ' 左端・上端を取得
    dblLeft = shp.CellsU("PinX").Result("in") - dblLocPinX
    dblTop = shp.CellsU("PinY").Result("in") + (dblHeight - dblLocPinY)
    
    ' 開始位置を考慮してグリッドに合わせる
    dblLeft = Round((dblLeft - dblOriginX) / dblGridX) * dblGridX + dblOriginX
    dblTop = Round((dblTop - dblOriginY) / dblGridY) * dblGridY + dblOriginY
    
    ' PinXYに戻す
    shp.CellsU("PinX").FormulaForce = (dblLeft + dblLocPinX) & " in"
    shp.CellsU("PinY").FormulaForce = (dblTop - (dblHeight - dblLocPinY)) & " in"

End Sub

コードの解説

ポイントを3つに絞って説明します。

① グリッド間隔を自動判定

intDensX = objPage.PageSheet.CellsU("XGridDensity").ResultIU

XGridDensity が 0 なら「固定」、それ以外なら「自動（粗い/普通/細かい）」です。固定の場合は XGridSpacing からそのまま間隔を取得します。自動の場合だと読み取りが面倒なのでInputBoxで入力してもらう形にしています。

②位置合わせのポイントはPinX/Y

PinX/Yってなんや？？？

PinX/Yは図形の中心、位置はここで管理してるんだ！

Visioの図形の位置はPinX/Yという中心座標で管理されています。「左上を指定したい」と思っても、直接左上の座標を設定するプロパティはありません。

そこでこのコードでは、一度左上の座標を計算してからPinX/Yに変換しています。

左上のX座標 = PinX - LocPinX
左上のY座標 = PinY + (Height - LocPinY)   ※Y軸は下から上！

グリッドに合わせた左上座標からPinX/Yに戻す時はこう計算します：

PinX = 補正後の左上X + LocPinX
PinY = 補正後の左上Y - (Height - LocPinY)

VisioのY軸は下から上向き！だから上端を求める時は「足し算」になるよ。詳しくはこちらの記事をどうぞ。

③ サイズ変更は位置合わせの前に

位置もだけど、図形のサイズも合わせたいときありますよね。
今回は図形の大きさをグリッドに合わせるオプションも用意しました～。

サイズを変えると LocPinX（中心オフセット）の値も変わります。先にサイズを確定させてから位置を計算しないとズレが生じるため、ResizeToGrid → SnapToGrid の順番で実行しています。

④ グリッドの開始位置設定を考慮

dblLeft = Round((dblLeft - dblOriginX) / dblGridX) * dblGridX + dblOriginX

グリッドの開始位置（XGridOrigin）が0以外の場合、開始位置を引いてからグリッドに合わせて、最後に足し戻しています。これを忘れるとグリッド線と微妙にズレた位置に補正されてしまいます。

おまけ①：グリッドを固定値に一発設定

補正マクロはグリッドの設定が自動だと手入力なのか？！

それすら毎回設定が面倒っ！ていう君のためにこれもマクロにしておいたよ

グリッドが「自動」のままだと補正マクロの都度InputBoxが出てしまいます。このコードでグリッドを「固定」に一発設定しておくと、補正マクロがスムーズに動きます。

' ===== グリッドを固定値に設定 =====
Sub SetGridFixed()

    Dim objPage As Visio.Page
    Dim strInput As String
    
    Set objPage = ActivePage
    
    ' 間隔を入力
    strInput = InputBox("グリッド間隔をmmで入力してください（例：8）", "グリッド固定設定", "8")
    If strInput = "" Then
        MsgBox "処理を中止しました。", vbInformation
        Exit Sub
    End If
       
    ' 固定に設定
    objPage.PageSheet.CellsU("XGridDensity").FormulaU = "0"
    objPage.PageSheet.CellsU("YGridDensity").FormulaU = "0"
    
    ' 間隔を設定
    objPage.PageSheet.CellsU("XGridSpacing").FormulaU = strInput & " mm"
    objPage.PageSheet.CellsU("YGridSpacing").FormulaU = strInput & " mm"
    
    MsgBox "グリッドを固定値 " & strInput & "mm に設定しました。", vbInformation

End Sub

おまけ②：スナップのON/OFF切り替え

「ちょっとだけグリッドを無視して自由に動かしたい」時に便利！

実行するたびにスナップのON/OFFが切り替わります。現在の状態を確認してから切り替えるので、今ONかOFFかを意識しなくて済みます。

' ===== スナップ ON/OFF 切り替え =====
Sub ToggleSnap()

    Dim objDoc As Visio.Document
    Set objDoc = ActiveDocument
    
    If objDoc.SnapEnabled Then
        objDoc.SnapEnabled = False
        MsgBox "スナップをOFFにしました。", vbInformation
    Else
        objDoc.SnapEnabled = True
        MsgBox "スナップをONにしました。", vbInformation
    End If

End Sub