| |
▼ｂｙｋｉｎ さん：
うーん、使ったことの無いコマンドが多くて理解できないところがありますが(^_^;
試してみました。
確かに先っぽは元の位置に戻ります。うれしいです！！
でも、ボックス内で改行などした時には、ボックスのｙ方向位置まで変わってしまうようです。
これまた疑問です。どうしてボックス側もずれてしまうのでしょう?
bykinさんのも参考に、作成用マクロと直し用マクロにしてみました。
わたしの理解範疇外のものは使わないで作ったので、いろいろ不具合あるかもしれません。
できれば不明なところ
Select Case .AutoShapeType
Case msoShapeRectangularCallout To msoShapeLineCallout4BorderandAccentBar
などの解説をいただけるとうれしいですが...(^_^;
Sub 作成()
Dim vLeft, vtop, vHeight, vWidth As Long
Dim svx As Double, svy As Double
With ActiveCell '位置調整
vHeight = 10
vWidth = 50
vLeft = .Left + .Width + 22
vtop = .Top - 15
End With
With ActiveSheet.Shapes.AddShape(msoShapeLineCallout3, vLeft, vtop, vWidth, vHeight)
svx = Round((.Adjustments(1) * vWidth + vLeft) / 0.75, 0) * 0.75
svy = Round((.Adjustments(2) * vHeight + vtop) / 0.75, 0) * 0.75
.AlternativeText = svx & "," & svy
.Fill.ForeColor.RGB = RGB(255, 204, 204)
With .Line
.ForeColor.SchemeColor = 20
.BeginArrowheadStyle = msoArrowheadOval
.EndArrowheadStyle = msoArrowheadOval
End With
With .TextFrame
With .Characters
.Text = ""
With .Font
.Name = "ＭＳ Ｐゴシック"
.Size = 8
End With
End With
.AutoSize = True
End With
.Select
SendKeys "> {BS}"
End With
End Sub
Sub 修正()
Dim cx As Single
Dim cy As Single
On Error Resume Next
For Each s In ActiveSheet.Shapes
With s
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 With
Next
End Sub
|
|
あくたいおん
- 06/7/26(水) 15:35 -
