| |
▼カド さん：
こんにちは。
>折角回答頂きましたが、任意の交わっている線をトリムできるマクロが
>出来たらいいなと思いましたが、教えていただいたものはちょっと
>違ってました。
>今回は断念します。
と仰っているのですが、トリミングでも出来ると思っていたので
投稿します。
トリミングするためには図として再作成しなければならないと思います。
新規ブックの標準モジュールに
'======================================================
Sub main()
Dim ww As Double
Dim wk As Double
Dim ln1 As Shape
Dim ln2 As Shape
Dim trm As Double
Dim shp As Shape
With Range("f10:g16")
ww = .Width
Set ln1 = ActiveSheet.Shapes.AddLine(.Left, .Top, .Left + .Width, .Top + .height)
Set ln2 = ActiveSheet.Shapes.AddLine(.Left, .Top + .height, .Left + .Width, .Top)
DoEvents
MsgBox "元になる二つの交差する直線"
Set shp = cnv_pic(ln1, ln2)
With shp
wk = .Width - ww
trm = (.Width - wk) / 2
.PictureFormat.CropLeft = trm
DoEvents
MsgBox "＜作成"
.PictureFormat.CropLeft = 0
.PictureFormat.CropRight = .Width - trm
DoEvents
MsgBox "＞作成"
End With
End With
End Sub
'==================================================================
Function cnv_pic(shp1 As Shape, shp2 As Shape) As Shape
'指定されたShapeをグループ化し、図として再作成する
Dim l As Double, t As Double
Dim gshp As Shape
Set gshp = shp1.Parent.Shapes.Range(Array(shp1.Name, shp2.Name)).Group
l = gshp.Left
t = gshp.Top
gshp.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set cnv_pic = shp1.Parent.Pictures.Paste.ShapeRange(1)
With cnv_pic
.Left = l
.Top = t
End With
gshp.Delete
End Function
これで、mainを実行して確認してみて下さい
「＜」と「＞」を順にトリミングで作成しています。
最終的に作成された「＞」の図も
「右クリック」---「図の書式設定」とクリックし、
「図」タブの「トリミング範囲」で設定することで別のトリミングも可能です。
試してみて下さい。
>また、貴殿のコードを改良する技量も持ち合わせておらず、
上記のコードだって恐らく変更しなければ
使えないと思います。
その時間が持てないのであれば、それは仕方ないですね！！
|
|
ichinose
- 06/7/23(日) 14:53 -
