textframeedit

　CorelDRAWは、好きなページ数を好きな並びで面付けをするという結構高等なことができます。通常のプリンタドライバや、ワープロなどでは、せいぜいパンフレット印刷という形で4面を既成の並びでするのが精一杯です。DRAWは、何のプラグインも使わず、印刷時のレイアウトで好きなようにレイアウトできます。そうすると、小さな手帳サイズのハンドブックのようなものを手作りするのも夢ではありません。
　ところが、DTPソフトのような使い方をしようとしても段落テキストへの流し込みだけでは、機能が足りません。具体的にどんな機能が不足しているかというと...

1. 　本文を流し込む領域サイズをマスターページとして定義できない。
2. 　テキスト全部を流し込んで段落テキストを生成するには、何も選択していない状態でテキストを貼り付けるというような操作をすることになるが、この場合、ページサイズのちょっと内側(A4にプレーンテキストをペースとした場合、2.5mm内側になる。)にサイズが固定されてしまい、本文領域としては広すぎる。
3. 　2.以外の方法では、テキストを全部流し込むフレームは自動生成できない。
4. 　フォント設定などをして、余りが出ても無駄なページが残る。/足りなくなっても追加フレームは生成されない。
5. 　本文領域のサイズ変更が他のリンクフレームに反映しない。

という具合です。いくつも書きましたが、根っこは同じ原因です。で、これで頑張ろうとすると、流し込んだり、本文領域のサイズや書体等を変更するたびに眠くなるような単純作業をしないといけません。そこでVBAです。

　サイズ変更の基準になる段落テキスト(フレームリンクの途中のものでも可。この場合、途中から本文サイズを変更することも可能になる。)を選択した状態でmain.AdjustFrameを実行します。

　ただ、段落テキスト周りのプロパティ、メソッドが、このような用途に使えないものばかりで、リンク情報で次のフレームを取得しても、サイズ変更や削除など、shapeとして操作可能なオブジェクトではありません。そこで、まず、ドキュメント内のすべてのオブジェクトをチェックして、選択したオブジェクトとリンク関係にある段落テキストのリストを生成し、このリストに基づいて処理をするようにしました。この際、同じリンクに属するかどうかを判断する簡単なプロパティが見あたらなかったので、story.textという「流し込まれた文章そのもの」が同じものかどうかを比較するというとんでもないことをしています。
　そして、オーバーフローしているかどうかを示すプロパティがtrueである間、空ページがあればそこへ、ページが足りなければページを追加して、初めに選択されていた段落テキストと同じ大きさ同じ位置の段落テキストを生成してリンクを張ってゆきます。
　この後、今度は余った(空の)フレームの有無をチェックして、無用なテキストフレームは削除します。最後に空のページがあるかチェックして、処理を終了します。

　同時にする必要のない処理もありますが、いくつもあるメソッドを選ぶより早いと思いこのようにしています。もし、余計な処理は不要であれば、起動チェックなどを付加してprivateプロシージャを外から見えるものに変更して利用してください。

　ホントは、こんな処理、デフォルトで欲しい気もしますし、VBAのオブジェクトモデルとしてもなんとか考えて欲しいものです。

　グローバル変数を利用しています。以下のコードは全体を同じモジュール内に置いてください。

---

Attribute VB_Name = "main"
'textframeedit(Adjust Frame)
'Copyright by albatross
'2004/01/26 Version 1.00

Option Explicit
  Dim ss As Shape
  Dim h As Double, w As Double, x As Double, y As Double
  Dim framlist() As Integer, links As Integer, startidx As Integer

Sub AdjustFrame()
  If envcheck Then Exit Sub
  makelist
  Set ss = ActiveShape
  h = ss.SizeHeight
  w = ss.SizeWidth
  x = ss.PositionX
  y = ss.PositionY
  samesize
  delframe
  delpage
  extentframe
End Sub

Private Sub extentframe()
  Dim s As Shape, d As Shape
  Dim p As Page
  Dim remc As Integer
  ss.CreateSelection
  makelist
  Set s = ActiveDocument.Pages(framlist(0, links)).Layers(framlist(1, links)).FindShape(, , framlist(2, links))
  remc = ActiveDocument.Pages.Count - framlist(0, links)
  While s.Text.Overflow
    If remc > 0 Then
      Set p = ActiveDocument.Pages(ActivePage.Index + 1)
      remc = remc - 1
    Else
      Set p = ActiveDocument.AddPages(1)
    End If
    p.Activate
    Set d = ActiveLayer.CreateParagraphText(1, 1, 2, 2)
    d.SizeHeight = h
    d.SizeWidth = w
    d.PositionX = x
    d.PositionY = y
    s.Text.Frame.LinkTo d
    Set s = d
  Wend
End Sub

Private Sub delframe()
  Dim s As Shape
  Dim i As Integer
  ss.CreateSelection
  makelist
  If ss.Text.UnusedFramesInLink = 0 Then Exit Sub
  For i = links To 2 Step -1
    Set s = ActiveDocument.Pages(framlist(0, i)).Layers(framlist(1, i)).FindShape(, , framlist(2, i))
    If s.Text.Frame.Empty Then s.Delete
  Next i
End Sub

Private Sub samesize()
  Dim s As Shape
  Dim i As Integer
  ss.CreateSelection
  makelist
  For i = startidx To links
    Set s = ActiveDocument.Pages(framlist(0, i)).Layers(framlist(1, i)).FindShape(, , framlist(2, i))
    s.SizeHeight = h
    s.SizeWidth = w
    s.PositionX = x
    s.PositionY = y
  Next i
End Sub

Private Function envcheck() As Boolean
  envcheck = False
  If ActiveDocument Is Nothing Then
    MsgBox "ドキュメントがありません", vbCritical, "Error"
    envcheck = True
    Exit Function
  End If
  If Application.ActiveSelection.Shapes.Count <> 1 Then
    MsgBox "オブジェクトが選択されていないか、複数選択されています", vbCritical, "Error"
    envcheck = True
    Exit Function
  End If
  If Application.ActiveSelection.Shapes(1).Type <> cdrTextShape Then
    MsgBox "選択されたオブジェクトはテキストではありません", vbCritical, "Error"
    envcheck = True
    Exit Function
  End If
  If Application.ActiveSelection.Shapes(1).Text.Type <> cdrParagraphText Then
    MsgBox "選択されたオブジェクトは段落テキストではありません", vbCritical, "Error"
    envcheck = True
    Exit Function
  End If
End Function

Private Sub makelist()
  Dim p As Page
  Dim l As Layer
  Dim s As Shape
  Dim t As String
  links = Application.ActiveSelection.Shapes(1).Text.FramesInLink
  startidx = Application.ActiveSelection.Shapes(1).Text.Frame.Index
  ReDim framlist(2, links)
  t = Application.ActiveSelection.Shapes(1).Text.Story.Text
  For Each p In ActiveDocument.Pages
    For Each l In p.Layers
      For Each s In l.Shapes
        If s.Type = cdrTextShape Then
          If s.Text.Type = cdrParagraphText Or cdrParagraphFittedText Then
            If t = s.Text.Story.Text Then
              framlist(0, s.Text.Frame.Index) = p.Index    'page
              framlist(1, s.Text.Frame.Index) = l.Index    'layer
              framlist(2, s.Text.Frame.Index) = s.StaticID 'id
            End If
          End If
        End If
  Next s, l, p
End Sub

Private Sub delpage()
  Dim p As Page
  For Each p In ActiveDocument.Pages
    If p.Shapes.Count = 0 Then p.Delete
  Next p
End Sub

---

＜＜戻る