| |
自分の作業が煮詰まったので試しに作ってみました。いつものごとく不恰好なリストですので、恥ずかしいのですが見てやってください。
(1)先ずUserForm1を作りLabel1とCommboButton1適当に配置して下さい。
(2)UserForm1に以下のコード貼り付けてください。
========================================================
Private Sub CommandButton1_Click()
With Selection
Select Case T_step
Case 0
'切断する線の名前の取得
Line_Name = .Name
'切断する線の状態取得
H_Flip = .ShapeRange.HorizontalFlip
V_Flip = .ShapeRange.VerticalFlip
If H_Flip = 0 Then
x_01 = .Left
x_02 = .Left + .Width
Else
x_01 = .Left + .Width
x_02 = .Left
End If
If V_Flip = 0 Then
y_01 = .Top
y_02 = .Top + .Height
Else
y_01 = .Top + .Height
y_02 = .Top
End If
'y＝α1 x ＋ β1 を取得
If x_01 = x_02 Then
α1 = 10 ^ 10: β1 = -x_01
ElseIf y_01 = y_02 Then
α1 = 0: β1 = y_01
Else
α1 = (y_02 y_01 /(x_02 - x_01): β1 = y_01 - α1 * x_01
End If
Cells(1, 1).Value = x_01: Cells(1, 2).Value = y_01
Cells(1, 3).Value = x_02: Cells(1, 4).Value = y_02
Cells(1, 5).Value = α1: Cells(1, 6).Value = β1
UserForm1.Label1.Caption = "切断基準になる線を選択した後CommandButtonを押して下さい。"
Case 1
'切断基準になる線の状態取得
H_Flip = .ShapeRange.HorizontalFlip
V_Flip = .ShapeRange.VerticalFlip
If H_Flip = 0 Then
x_11 = .Left
x_12 = .Left + .Width
Else
x_11 = .Left + .Width
x_12 = .Left
End If
If V_Flip = 0 Then
y_11 = .Top
y_12 = .Top + .Height
Else
y_11 = .Top + .Height
y_12 = .Top
End If
'y＝α2 x ＋ β2 を取得
If x_11 = x_12 Then
α2 = 10 ^ 10: β2 = -x_11
ElseIf y_11 = y_12 Then
α2 = 0: β2 = y_11
Else
α2 = (y_12-y_11) / (x_12-x_11): β2 = y_11- α2 * x_11
End If
'交点の取得
If α1 = α2 Then MsgBox "２直線が平行で交わりません。終了します。": T_step = 0: Exit Sub
x_03 = (β2 - β1) / (α1 - α2)
y_03 = α1 * x_03 + β1
Cells(2, 1).Value = x_11: Cells(2, 2).Value = y_11
Cells(2, 3).Value = x_12: Cells(2, 4).Value = y_12
Cells(2, 5).Value = α2: Cells(2, 6).Value = β2
Cells(3, 1).Value = x_03: Cells(3, 2).Value = y_03
dx = 0.5 '交差判定の制度dxが大きいほど甘い
If x_01 < x_02 Then
If x_01-dx < x_03 And x_03 < x_02 + dx Then Else GoTo 10
Else
If x_01+dx > x_03 And x_03 > x_02 - dx Then Else GoTo 10
End If
If x_11 < x_12 Then
If x_11-dx < x_03 And x_03 < x_12 + dx Then Else GoTo 10
Else
If x_11+dx > x_03 And x_03 > x_12 - dx Then Else GoTo 10
End If
UserForm1.Label1.Caption = "切断する部位の近くでダブルクリックして下さい。"
Case Else
MsgBox "CommandButtonでは無く、切断する部位の近くでダブルクリックして下さい。": Exit Sub
End Select
T_step = T_step + 1
End With
Exit Sub
10:
MsgBox "２直線の交点が線上に存在しません。終了します。"
End Sub
(3)次に標準モジュールに以下を貼付、線図作成はichinoseさんのをお借りします
'======================================================
Public T_step As Integer
Public Line_Name As String
Public α1 As Double
Public β1 As Double
Public α2 As Double
Public β2 As Double
Public x_01 As Double
Public x_02 As Double
Public x_03 As Double
Public x_04 As Double
Public x_11 As Double
Public x_12 As Double
Public y_01 As Double
Public y_02 As Double
Public y_03 As Double
Public y_04 As Double
Public y_11 As Double
Public y_12 As Double
'
'======================================
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
(4)Sheet1に以下を貼り付ける。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
With Target
x_04 = .Left
y_04 = .Top
End With
ActiveSheet.Shapes(Line_Name).Select
With Selection
If T_step = 2 Then
len_01 = (x_01 - x_04) ^ 2 + (y_01 - y_04) ^ 2
len_02 = (x_02 - x_04) ^ 2 + (y_02 - y_04) ^ 2
If len_01 > len_02 Then
If x_01 < x_03 Then
.Left = x_01
.Width = x_03 - x_01
Else
.Left = x_03
.Width = x_01 - x_03
End If
If y_01 < y_03 Then
.Top = y_01
.Height = y_03 - y_01
Else
.Top = y_03
.Height = y_01 - y_03
End If
Else
If x_02 < x_03 Then
.Left = x_02
.Width = x_03 - x_02
Else
.Left = x_03
.Width = x_02 - x_03
End If
If y_02 < y_03 Then
.Top = y_02
.Height = y_03 - y_02
Else
.Top = y_03
.Height = y_02 - y_03
End If
End If
T_step = 0
Unload UserForm1
Else
'作業無し
End If
End With
End Sub
後はMacro1を実行して、メッセージに従えばトリムできると思います。
削除後の線頭と線尾が変わってしまいます。その辺は調整してください。
長くなりましたが、機会があったら試してみて下さい。
|
|
わいわい
- 06/7/26(水) 19:03 -
