| |
▼カド さん：
こんばんは。
新規ブックの標準モジュールに
'======================================================
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'======================================
Sub mk_line()
With Range("f10:g16")
ActiveSheet.Shapes.AddLine .Left, .Top, .Left + .Width, .Top + .Height
ActiveSheet.Shapes.AddLine .Left, .Top + .Height, .Left + .Width, .Top
ActiveSheet.Shapes.AddLine .Left + .Width / 3, .Top, .Left + .Width / 3, .Top + .Height
ActiveSheet.Shapes.AddLine .Left, .Top + .Height / 3, .Left + .Width, .Top + .Height / 3
End With
End Sub
'===========================================================
Sub main()
Dim ww As Double
Dim ln1 As Shape
Dim ln2 As Shape
Dim trm As Double
Dim shp As Shape
Set ln1 = Selection.ShapeRange(1)
Set ln2 = Selection.ShapeRange(2)
Set shp = cnv_pic(ln1, ln2)
With shp
.Select
trm = 0
ww = .Width
On Error Resume Next
Do While trm <= 100
Err.Clear
.PictureFormat.CropLeft = trm / 100 * ww
Sleep 50
DoEvents
If Selection.Name <> .Name Then Exit Do
If Err.Number <> 0 Then Exit Do
trm = trm + 1
Loop
On Error GoTo 0
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
まず、mk_lineを実行して、交差する4本の線を作図します。
この4本の中から、２本の線を選択した状態で（Shiftを押しながら二つ線を選択します）
mainを実行します。
少しずつトリミングしていきます。止めたい箇所で適当なセルを選択してください。
（トリミング中はセルを選択していません。監視していてセルが選択されると
トリミングを中止します）
試してみて下さい。
|
|
ichinose
- 06/7/24(月) 22:44 -
