| |
こんばんわ。
>私としてはひとつは複数の吹出しの整理について
>こちらでは吹出しのテキストボックスの自動生成時の文字編集状態について
>と吹出しの自動サイズ調整時について
>と別の質問と考えていました。
あー、そーいうことでっか。
あんまりご質問が似てたもんで・・・失礼しました。
で、このご質問の件でっけど、
>吹出しがセレクトされたときに２）をするようにすればうまくいくかと
Shapeを操作したときに起動するイベントはないから
やっぱり手作業でマクロを実行させることになるんとちゃうかな？
↓お二人のアイデア拝借して・・・こんな感じ？
Public Sub SetInitialValue()
Dim s As Shape
Dim cx As Single
Dim cy As Single
On Error Resume Next
For Each s In ActiveSheet.Shapes
With s
Select Case .AutoShapeType
Case msoShapeRectangularCallout To msoShapeLineCallout4BorderandAccentBar
cx = .Adjustments(1) * .Width + .Left
cy = .Adjustments(2) * .Height + .Top
.AlternativeText = cx & "," & cy
.TextFrame.AutoSize = True
End Select
End With
Next
End Sub
Public Sub SetAllCallout()
Dim s As Shape
For Each s In ActiveSheet.Shapes
SetCallout s
Next
End Sub
Sub SetSelectedCallout()
Dim s As Object
On Error Resume Next
Set s = Selection.ShapeRange
If Err.Number = 0 Then
SetCallout s
End If
Set s = Nothing
End Sub
Private Sub SetCallout(ByRef s As Object)
Dim cx As Single
Dim cy As Single
With s
Select Case .AutoShapeType
Case msoShapeRectangularCallout To msoShapeLineCallout4BorderandAccentBar
If .AlternativeText Like "*,*" Then
cx = CSng(Left$(.AlternativeText, InStr(.AlternativeText, ",") - 1))
cy = CSng(Mid$(.AlternativeText, InStr(.AlternativeText, ",") + 1))
.Adjustments(1) = (cx - .Left) / .Width
.Adjustments(2) = (cy - .Top) / .Height
End If
End Select
End With
End Sub
（使い方）
１．任意の個数の吹き出しをシート上に適当に配置して先端位置を決定し、
適当な文字列を入力する。
２．SetInitialValueを実行する。
→自動調整を設定し、先端位置をAlternativeTextに記憶。
３．吹き出しの文字列を変更する。→先端の位置が変化する。
４．特定の吹き出しの先端位置を元に戻す場合は、当該吹き出しを選択してから
SetSelectedCalloutを実行する。
５．全部の吹き出しを一括修正する場合はSetAllCalloutを実行する。
DPIは考慮したほうがええんやろうけど、これくらいやったらこのままでもええと思います。
試してみてな。
ほな。
|
|
ｂｙｋｉｎ
- 06/7/21(金) 23:36 -
