mkcaption

　オブジェクトの左上にキャプションをつけるコードです。
　まず準備としてオブジェクトデータマネージャでキャプションをつけたいオブジェクトの「名前」フィールドにキャプションとして付けたい文字を入力します。これで、キャプションとオブジェクトが泣き別れになることはありません。
　つぎに、そのオブジェクトのみを選択した状態にして、このコードを実行します。
　これだけです。コードの中のspという定数はオブジェクト上端とキャプション文字下端の隙間をmmで指定しています。また、fsという定数は、キャプション文字のフォントサイズをポイントで指定しています。必要に応じて変更してください
　これ、実はまだ未完成です。(こればっか)
　本当は、フォント名を変更し、基準オブジェクトの幅まで広げてやりたいんですが、フォント名の指定のための.text.fontproperties.nameと文字間隔指定のための.Text.SpaceProperties.CharacterSpacingというプロパティがうまく実行できないのです。(これがSP1を当てていないせいか、当ててもだめなのか、はたまた、私の勉強不足かはわかりません。)コードはエラーを起こさずに走るのですが、結果が変わらない。～デフォルトのアートテキストのスタイルに設定されているフォントとスペースになります。～
　オブジェクトはOLEコンテナなども扱えますので、何にでもキャプション付けることができます。

2001/01/12
　ちょいと改良しました。
プロパティでやるのはあきらめて、スタイルで処理するようにしました。これなら、文字長さに応じた間隔の調整以外は欧文フォントと日本語フォントの使い分けも同時にできます。また、文字詰めを左寄せ、センタリング、右寄せの中から、キャプションを付ける場所をオブジェクト上方、下方のいずれかを選択できるようにしました。編集方針で同じ動作になると勝手に考え、コードの前の方に定数としてこれらの設定を集めました。そして、変形-スケール相当の機能としてオブジェクトサイズより大きなキャプションは横方向を圧縮するようにしました。

sp
　上述のまま、オブジェクトとキャプションの間隔をmm単位で指定します。
af
　文字詰めで、左寄せなら"L"、センタリングなら"C"、右寄せなら"R"と指定してください。
bf
　キャプションを付ける位置で、下ならtrue、上ならfalseと指定してください。
stylename
　適用するスタイルです。ここにだけエラー処理施してありますので、指定したスタイルがなくてもエラーを出しません。
zf
　キャプションのズームを選択します。ズームする場合はtrue、しない場合はfalseと指定してください。

オブジェクトデータのありかオブジェクトデータマネージャはここにあります。
オブジェクトデータの設定名前フィールドにキャプション文字を設定します
実行結果実行するとこのようになります

Sub mkcaption()
'copyright by Albatros
'Ver 1.00 2001/01/07 Initial Version
'Ver 1.01 2001/01/12 センタリング,スタイル使用,下側,右寄せ,ズーム

    Const sp As Long = 2
    'gap in mm
    Const af As String = "C"
    '左寄せ="L",センタリング="C",右寄せ="R"
    Const bf As Boolean = False
    '下=true,上=false
    Const stylename As String = "caption"
    Const zf As Boolean = True
    'zoom=true, no-zoom=false

    Dim orp As Integer, ou As Integer
    Dim o As Shape, oo As Shape
    Dim x As Double, y As Double
    Dim spd As Double
    Dim caption As String
    
    spd = sp * 10000 * IIf(bf, -1, 1)
    
    If ActiveDocument Is Nothing Then
        MsgBox "ドキュメントがありません", vbCritical, "Error"
        Exit Sub
    End If
    If Application.ActiveSelection.Shapes.Count <> 1 Then
        MsgBox "オブジェクトが複数選択されています", vbCritical, "Error"
        Exit Sub
    End If
    ou = ActiveDocument.Unit
    orp = ActiveDocument.ReferencePoint
    ActiveDocument.Unit = cdrTenthMicron
    If bf Then
        ActiveDocument.ReferencePoint = cdrBottomLeft
    Else
        ActiveDocument.ReferencePoint = cdrTopLeft
    End If
    
    Set oo = ActiveSelection.Shapes(1)
    caption = oo.ObjectData("名前").Value
    If caption <> "" Then
        ActiveSelection.Shapes(1).GetPosition x, y
        Set o = ActiveLayer.CreateArtisticText(x, y + spd, caption)
        On Error Resume Next
        CorelScript.ApplyStyle stylename
        If zf And oo.SizeWidth < o.SizeWidth Then
            o.Stretch (oo.SizeWidth / o.SizeWidth), 1#
        End If
        Select Case af
            Case "C"
                o.PositionX = o.PositionX + (oo.SizeWidth - o.SizeWidth) / 2
            Case "R"
                o.PositionX = o.PositionX + (oo.SizeWidth - o.SizeWidth)
        End Select
        If bf Then
            o.PositionY = o.PositionY - o.SizeHeight
        End If
    End If
    ActiveDocument.Unit = ou
    ActiveDocument.ReferencePoint = orp
End Sub

＜＜戻る