InDesignで角丸長方形に変換、または作成を行う

Dim app 'As InDesign.Application
Dim err_msg 'As String
Dim i 'As Integer
err_msg = ""

Set app = CreateObject("InDesign.Application.CS")
If app.Documents.Count = 0 Then
    err_msg = "開いているドキュメントがありません。処理を中止します"
End If
If app.Selection.Count > 0 Then
    If err_msg = "" Then
        For i = 1 To app.Selection.Count
            If TypeName(app.Selection(i)) <> "Rectangle" Then
                err_msg = "長方形でないオブジェクトが選択されています。処理を中止します"
                Exit For
            End If
        Next 'i
    End If
    If err_msg = "" Then
        For i = 1 To app.Selection.Count
            If app.Selection(i).RotationAngle <> 0 Then
                err_msg = "回転している長方形では実行できません。処理を中止します"
                Exit For
            End If
        Next 'i
    End If
    If err_msg = "" Then
        For i = 1 To app.Selection.Count
            If app.Selection(i).ShearAngle <> 0 Then
                err_msg = "シアーのかかった長方形では実行できません。処理を中止します"
                Exit For
            End If
        Next 'i
    End If
End If
If err_msg <> "" Then
    MsgBox err_msg
Else
    make_rrect app, app.Selection.Count
End If

Sub make_rrect(app, s)
    Dim dlg 'As InDesign.Dialog
    Dim dlc 'As InDesign.DialogColumn
    Dim dlr 'As InDesign.DialogRow
    Dim dw, dh, dr, dr0, dr1, dr2, dr3 'As InDesign.RealEditbox
    Dim de 'As InDesign.EnablingGroup
    Dim du 'As InDesign.DropDown
    Dim rec 'As InDesign.Rectangle
    Dim tgt 'As InDesign.Path
    Dim c(3), w, h, umax, t, l, b, r 'As Double
    Dim i, j, u 'As Integer
    Dim org_h, org_v 'As Long
    Dim err_flag 'As Boolean
    Dim un, ub, ux
    
    Const p = 0.4477 'ここが疑似角丸の所以
    '使用する単位の設定
    un = Array("ポイント", "インチ", "ミリメートル", "センチメートル", "歯", "アメリカ式ポイント")
    ub = Array(2054188905, 2053729891, 2053991795, 2053336435, 1516790048, 1514238068)
    ux = Array(1, 0.0138889, 0.3528, 0.03528, 1.4112, 1.003921)
    u = p_of_l(ub, app.ActiveDocument.ViewPreferences.HorizontalMeasurementUnits)
    If u = -1 Then u = 2
    umax = 15552 * ux(u) '幅と高さの最大値（ドキュメントの最大値に合わせてあります）
    
    '選択された長方形の幅と高さの最小値を取得
    If s > 0 Then
        w = umax
        h = umax
        For i = 1 To s
            With app.Selection(i)
                If .GeometricBounds(2) - .GeometricBounds(0) < h Then _
                    h = .GeometricBounds(2) - .GeometricBounds(0)
                If .GeometricBounds(3) - .GeometricBounds(1) < w Then _
                    w = .GeometricBounds(3) - .GeometricBounds(1)
            End With
        Next 'i
    End If
    
    'ここからダイアログを作成
    Set dlg = app.Dialogs.Add
    If s = 0 Then dlg.Name = "角丸長方形の作成"
    If s > 0 Then dlg.Name = "角丸長方形へ変換"
    Set dlc = dlg.DialogColumns.Add
    
    Set dlr = dlc.DialogRows.Add '1行目
    dlr.StaticTexts.Add
    If s = 0 Then
        dlr.StaticTexts(1).StaticLabel = "長方形の幅："
        Set dw = dlr.RealEditboxes.Add
        dw.MinWidth = 80
        dw.MinimumValue = 0
        dw.MaximumValue = umax
        dlr.StaticTexts.Add
        dlr.StaticTexts(2).StaticLabel = "　長方形の高さ："
        Set dh = dlr.RealEditboxes.Add
        dh.MinWidth = 80
        dh.MinimumValue = 0
        dh.MaximumValue = umax
    ElseIf s = 1 Then
        dlr.StaticTexts(1).StaticLabel = "長方形の幅：" & CStr(w)
        dlr.StaticTexts.Add
        dlr.StaticTexts(2).StaticLabel = "　長方形の高さ：" & CStr(h)
    Else
        dlr.StaticTexts(1).StaticLabel = "幅の最小値：" & CStr(w)
        dlr.StaticTexts.Add
        dlr.StaticTexts(2).StaticLabel = "　高さの最小値：" & CStr(h)
    End If
    
    Set dlr = dlc.DialogRows.Add '2行目
    dlr.StaticTexts.Add
    dlr.StaticTexts(1).StaticLabel = "角丸の半径："
    Set dr = dlr.RealEditboxes.Add
    dr.MinWidth = 80
    dr.MinimumValue = 0
    If s = 0 Then
        dr.MaximumValue = umax / 2
    Else
        If w > h Then dr.MaximumValue = h / 2
        If w <= h Then dr.MaximumValue = w / 2
    End If
    dlr.StaticTexts.Add
    If s = 0 Then
        dlr.StaticTexts(2).StaticLabel = "　単位："
        Set du = dlr.DropDowns.Add
        du.MinWidth = 80
        du.StringList = un
        du.SelectedIndex = u
    Else
        dlr.StaticTexts(2).StaticLabel = "　単位：" & un(u)
    End If
    
    Set dlr = dlc.DialogRows.Add '3行目
    Set de = dlr.EnablingGroups.Add
    de.CheckedState = False
    de.StaticLabel = "角丸の半径を個別に設定する"
    Set dlc = de.DialogColumns.Add
    Set dlr = dlc.DialogRows.Add
    dlr.StaticTexts.Add
    dlr.StaticTexts(1).StaticLabel = "　左上："
    Set dr0 = dlr.RealEditboxes.Add
    dr0.MinWidth = 80
    dr0.MinimumValue = 0
    dr0.MaximumValue = dr.MaximumValue * 2
    Set dlr = dlc.DialogRows.Add
    dlr.StaticTexts.Add
    dlr.StaticTexts(1).StaticLabel = "　左下："
    Set dr1 = dlr.RealEditboxes.Add
    dr1.MinWidth = 80
    dr1.MinimumValue = 0
    dr1.MaximumValue = dr.MaximumValue * 2
    Set dlc = de.DialogColumns.Add
    Set dlr = dlc.DialogRows.Add
    dlr.StaticTexts.Add
    dlr.StaticTexts(1).StaticLabel = "　　右上："
    Set dr3 = dlr.RealEditboxes.Add
    dr3.MinWidth = 80
    dr3.MinimumValue = 0
    dr3.MaximumValue = dr.MaximumValue * 2
    Set dlr = dlc.DialogRows.Add
    dlr.StaticTexts.Add
    dlr.StaticTexts(1).StaticLabel = "　　右下："
    Set dr2 = dlr.RealEditboxes.Add
    dr2.MinWidth = 80
    dr2.MinimumValue = 0
    dr2.MaximumValue = dr.MaximumValue * 2
    
    '半径の値のチェック
    Do
        err_flag = False
        If dlg.Show = False Then Exit Sub
        If s = 0 Then
            w = dw.EditValue
            h = dh.EditValue
            If w = 0 Or h = 0 Then
                MsgBox "幅もしくは高さが入力されていないか、無効な値です。"
                err_flag = True
            End If
        End If
        If err_flag = False And de.CheckedState = False Then
            If dr.EditValue = 0 Then
                MsgBox "角丸の半径が入力されていないか、無効な値です。"
                err_flag = True
            ElseIf dr.EditValue > h / 2 Then
                MsgBox "半径の大きさが幅の半分を超えています。"
                err_flag = True
            ElseIf dr.EditValue > w / 2 Then
                MsgBox "半径の大きさが高さの半分を超えています。"
                err_flag = True
            End If
        End If
        If err_flag = False And de.CheckedState = True Then
            If dr0.EditValue + dr1.EditValue > h Then
                MsgBox "左上と左下の半径の合計が高さを超えています。"
                err_flag = True
            End If
            If dr1.EditValue + dr2.EditValue > w Then
                MsgBox "左下と右下の半径の合計が幅を超えています。"
                err_flag = True
            End If
            If dr2.EditValue + dr3.EditValue > h Then
                MsgBox "右上と右下の半径の合計が高さを超えています。"
                err_flag = True
            End If
            If dr3.EditValue + dr0.EditValue > w Then
                MsgBox "左上と右上の半径の合計が高さを超えています。"
                err_flag = True
            End If
            If dr0.EditValue + dr1.EditValue + dr2.EditValue + dr3.EditValue = 0 Then
                MsgBox "丸くする角がありません。"
                err_flag = True
            End If
        End If
    Loop While err_flag = True
    
    If de.CheckedState = True Then
        c(0) = dr0.EditValue
        c(1) = dr1.EditValue
        c(2) = dr2.EditValue
        c(3) = dr3.EditValue
    Else
        c(0) = dr.EditValue
        c(1) = dr.EditValue
        c(2) = dr.EditValue
        c(3) = dr.EditValue
    End If
    If s = 0 Then
        u = du.SelectedIndex
        org_h = app.ActiveDocument.ViewPreferences.HorizontalMeasurementUnits
        org_v = app.ActiveDocument.ViewPreferences.VerticalMeasurementUnits
        app.ActiveDocument.ViewPreferences.HorizontalMeasurementUnits = ub(u)
        app.ActiveDocument.ViewPreferences.VerticalMeasurementUnits = ub(u)
        Set rec = app.ActiveDocument.Rectangles.Add
        rec.GeometricBounds = Array(0, 0, h, w)
        rec.Select
        '以下の2行は単に画面の中央に配置するため
        app.Cut
        app.Paste
    End If
    dlg.Destroy
    
    For i = 1 To app.Selection.Count
        Set tgt = app.Selection(i).Paths(1)
        t = tgt.Parent.GeometricBounds(0)
        l = tgt.Parent.GeometricBounds(1)
        b = tgt.Parent.GeometricBounds(2)
        r = tgt.Parent.GeometricBounds(3)
        For j = 1 To 4
            tgt.PathPoints.Add
        Next 'j
        tgt.PathPoints(1).Anchor = Array(l, t + c(0))
        tgt.PathPoints(1).LeftDirection = Array(l, t + c(0) * p)
        tgt.PathPoints(2).Anchor = Array(l, b - c(1))
        tgt.PathPoints(2).RightDirection = Array(l, b - c(1) * p)
        tgt.PathPoints(3).Anchor = Array(l + c(1), b)
        tgt.PathPoints(3).LeftDirection = Array(l + c(1) * p, b)
        tgt.PathPoints(4).Anchor = Array(r - c(2), b)
        tgt.PathPoints(4).RightDirection = Array(r - c(2) * p, b)
        tgt.PathPoints(5).Anchor = Array(r, b - c(2))
        tgt.PathPoints(5).LeftDirection = Array(r, b - c(2) * p)
        tgt.PathPoints(6).Anchor = Array(r, t + c(3))
        tgt.PathPoints(6).RightDirection = Array(r, t + c(3) * p)
        tgt.PathPoints(7).Anchor = Array(r - c(3), t)
        tgt.PathPoints(7).LeftDirection = Array(r - c(3) * p, t)
        tgt.PathPoints(8).Anchor = Array(l + c(0), t)
        tgt.PathPoints(8).RightDirection = Array(l + c(0) * p, t)
    Next 'i
    
    If s = 0 Then
        app.ActiveDocument.ViewPreferences.HorizontalMeasurementUnits = org_h
        app.ActiveDocument.ViewPreferences.VerticalMeasurementUnits = org_v
    End If
    
End Sub

Function p_of_l(list, valu)
    Dim i 'As Integer
    p_of_l = -1
    For i = LBound(list) To UBound(list)
        If list(i) = valu Then
            p_of_l = i
            Exit For
        End If
    Next 'i
End Function