'フリーフォームの頂点をセルに合わせるマクロ(Excel97)

'フリーフォームを選択し、AutoNodePos マクロを実行してください。
'マクロ実行直後に限り AutoNodePosUndo マクロで元に戻すことが
'できます。それ以外のタイミングでの実行結果は不定です。

Option Explicit

Private sfNodePoint() As Single
Private oShapePrev As Object

Sub AutoNodePos()
    Dim oShape As Shape
    Dim oNode As ShapeNode
    Dim oRange As Range
    Dim oCell As Range
    Dim x As Single
    Dim y As Single
    Dim w1 As Single
    Dim w2 As Single
    Dim i As Long

    On Error Resume Next
    Set oShape = Selection.ShapeRange(1)
    Set oNode = oShape.Nodes(1)
    If oNode Is Nothing Then
        MsgBox "頂点の編集が可能なオブジェクトを選択して実行してください。", vbExclamation
        Exit Sub
    End If

    On Error GoTo ErrorHandler

    Set oShapePrev = oShape
    ReDim sfNodePoint(1 To oShape.Nodes.Count * 2)
    i = 1
    For Each oNode In oShape.Nodes
        sfNodePoint(i) = oNode.Points(1, 1)
        sfNodePoint(i + 1) = oNode.Points(1, 2)
        i = i + 2
    Next

    For i = 1 To oShape.Nodes.Count
        Set oRange = oShape.Parent.Range(oShape.TopLeftCell, oShape.BottomRightCell)
        Set oNode = oShape.Nodes(i)
        x = oNode.Points(1, 1)
        y = oNode.Points(1, 2)
        Set oCell = CellFromPoint(oRange, x, y)

        w1 = oCell.Left
        w2 = oCell.Width
        If x <= (w1 + w2 / 2) Then
            x = w1
        Else
            x = w1 + w2
        End If

        w1 = oCell.Top
        w2 = oCell.Height
        If y <= (w1 + w2 / 2) Then
            y = w1
        Else
            y = w1 + w2
        End If
        oShape.Nodes.SetPosition i, x, y
    Next
    Exit Sub
ErrorHandler:
    MsgBox Error(Err) & " (" & Err & ")", vbExclamation
    Exit Sub
End Sub

Function CellFromPoint(ByVal oRange As Range, _
        ByVal x As Double, ByVal y As Double) As Range
    Dim iLeft As Long
    Dim iRight As Long
    Dim iMid As Long
    Dim iRow As Long
    Dim iColumn As Long
    Dim iRowCount As Long
    Dim iColumnCount As Long
    Dim w As Double

    x = Int(x * 10000 + 0.01)
    y = Int(y * 10000 + 0.01)
    iRowCount = oRange.Rows.Count
    iColumnCount = oRange.Columns.Count

    iLeft = 1
    iRight = iColumnCount
    Do While iLeft <= iRight
        iMid = (iLeft + iRight) \ 2
        w = Int(oRange.Cells(1, iMid).Left * 10000 + 0.01)
        If w > x Then
            iRight = iMid - 1
        Else
            iLeft = iMid + 1
        End If
    Loop
    iColumn = iRight

    If iColumn < 1 Then
        Exit Function
    End If

    With oRange.Cells(1, iColumn)
        w = Fix((.Left + .Width) * 10000 + 0.01)
    End With
    If w < x Then
        Exit Function
    End If

    iLeft = 1
    iRight = iRowCount
    Do While iLeft <= iRight
        iMid = (iLeft + iRight) \ 2
        w = Int(oRange.Cells(iMid, 1).Top * 10000 + 0.01)
        If w > y Then
            iRight = iMid - 1
        Else
            iLeft = iMid + 1
        End If
    Loop
    iRow = iRight

    If iRow < 1 Then
        Exit Function
    End If

    With oRange.Cells(iRow, 1)
        w = Fix((.Top + .Height) * 10000 + 0.01)
    End With
    If w < y Then
        Exit Function
    End If

    Set CellFromPoint = oRange.Cells(iRow, iColumn)

End Function

Sub AutoNodePosUndo()
    Dim i As Long
    If oShapePrev Is Nothing Then Exit Sub
    For i = 1 To oShapePrev.Nodes.Count
        oShapePrev.Nodes.SetPosition i, sfNodePoint(i * 2 - 1), sfNodePoint(i * 2)
    Next
End Sub