'等分割線作成(平行＆角度Version)			By Den
'2003/08/01 	平行Versionと角度Versionを作成
'2005/04/30 	合体して どっちでもいいよVersion を作成
'2005/05/02 	再作図付きダイアログ作成
'2005/05/06 	UCSと鉛直線(90度270度)の不具合修正
'2005/09/30 	角度の基点方向(ANGBASE)に対応。角度計算にCalcAngleを使用。
'2005/10/01 	角度の方向(ANGDIR)の時計回りに対応。
'2006/01/22		作図の不具合を修正
'2006/01/28		角度精度を６桁にして平行線を判定するようにした

Dim Acad,Bun
Call Main

Sub Main()
	Set Acad = CreateObject("AcadRemocon.Body")
	Acad.GetIniVal Bun, "分割数", "Den等分割線" 			'設定ファイルを読込
	Acad.acGetvar "angbase",AngBase 						'角度の基点方向読込み
	n = InStr(1, AngBase, "d")								'度分秒設定なら度数のみを抽出
	If n <> 0 Then
		kaku = Split(AngBase, "d")
		AngBase = Acad.vbVal(kaku(0))
	End If
	Acad.acGetvar "angdir",AngDir							'角度の方向(時計回り=1)
	Acad.acPostCommand "ucs^Mw^M"							'UCSをワールドにする
	Do
		DialogCreate										'ダイアログ作成&表示
		Do													'イベント監視ループ
			Acad.dlWaitEvent CtrlName, CtrlValue, CtrlListIndex
			Select Case CtrlName
				Case "cmdGo"
					Exit Do
				Case "cmdCancel"
					Er: Exit Sub
				Case "cmdRe"
					Acad.acPostCommand "_undo^Mb^M" 		'アンドゥ後退
					Exit Do
			End Select
		Loop While True
		Bun = Acad.dlGetValue("cmb1")				'ダイアログ数値取得
		Acad.PutIni Bun, "分割数", "Den等分割線"	'設定ファイルに保存
		Acad.dlUnload								'ダイアログアンロード
		Do
			If Not Acad.acDxfOut("【最初の線分を選択/[Enter]でメニュー】","SGL") Then Exit Do
			If Not Acad.DxfExtract(N, XY, "ENTITIES", "", "LINE", "10|20|11|21") Then Er: Exit Sub
			X1 = XY(1, 1): Y1 = XY(2, 1): X2 = XY(3, 1): Y2 = XY(4, 1)
			If Not Acad.acDxfOut("【他方の線分を選択/[Enter]でメニュー】","SGL") Then Exit Do
			If Not Acad.DxfExtract(N, XY, "ENTITIES", "", "LINE", "10|20|11|21") Then Er: Exit Sub
			X3 = XY(1, 1): Y3 = XY(2, 1): X4 = XY(3, 1): Y4 = XY(4, 1)

			OK = Acad.CalcCrossPoint (X0,Y0,X1,Y1,X2,Y2,X3,Y3,X4,Y4,0.00001)		'交点計算
			L1=((X1-X0)^2+(Y1-Y0)^2)^0.5: L2=((X2-X0)^2+(Y2-Y0)^2)^0.5		'直線1の端点と交点の距離計算
			L3=((X3-X0)^2+(Y3-Y0)^2)^0.5: L4=((X4-X0)^2+(Y4-Y0)^2)^0.5		'直線2の端点と交点の距離計算
			If L1 > L2 Then 												'直線1の並び替え
				Tmp = X1: X1 = X2: X2 = Tmp
				Tmp = Y1: Y1 = Y2: Y2 = Tmp
				Tmp = L1: L1 = L2: L2 = Tmp
			End If
			L1=((X2-X0)^2+(Y2-Y0)^2)^0.5-((X2-X1)^2+(Y2-Y1)^2)^0.5			'交点を突き抜けた場合の処理
			If L3 > L4 Then 												'直線2の並び替え
				Tmp = X3: X3 = X4: X4 = Tmp
				Tmp = Y3: Y3 = Y4: Y4 = Tmp
				Tmp = L3: L3 = L4: L4 = Tmp
			End If
			L3=((X4-X0)^2+(Y4-Y0)^2)^0.5-((X4-X3)^2+(Y4-Y3)^2)^0.5			'交点を突き抜けた場合の処理

			Acad.acPostCommand "_undo^Mm^M" 								'アンドゥマーク設定
			If OK = 0 Then										   '平行線の処理
				DX1 = (X3 - X1) / Bun: DY1 = (Y3 - Y1) / Bun	   '分割線の変化量
				DX2 = (X4 - X2) / Bun: DY2 = (Y4 - Y2) / Bun
				For i = 1 To Bun-1								   '分割線作図
					X1 = X1 + DX1: Y1 = Y1 + DY1
					X2 = X2 + DX2: Y2 = Y2 + DY2
					Acad.acLine X1, Y1, X2, Y2
				Next
			Else											'角度分割の処理
				a1 = Acad.CalcAngle (X0,Y0,X2,Y2,True)		'線分1の角度計算
				a2 = Acad.CalcAngle (X0,Y0,X4,Y4,True)		'線分2の角度計算

				If a2<a1 Then a2=a2+360 					'鈍角の場合の処理
				a3 = (a2 - a1) / Bun
				DL1 = (L3 - L1) / Bun: DL2 = (L4 - L2) / Bun
				Acad.acPostCommand "ucs^Mo^Mnon^M"&X0&","&Y0&"^M"			'原点移動
				a1=a1-AngBase												'角度の基点方向の処理
				If AngDir=1 Then a1=-a1: a3=-a3 							'時計回りの場合の処理
				For i = 1 To Bun-1											'分割線作図
					L1 = L1 + DL1: L2 = L2 + DL2: a1 = a1 + a3
					Acad.acSendCommand "line^Mnon^M"&L1&"<"&a1&"^Mnon^M"&L2&"<"&a1&"^M^M"
				Next
				Acad.acPostCommand "ucs^Mp^M"								'原点を戻す
			End If
			Exit Do
		Loop
	Loop
End Sub


Sub DialogCreate()				'ダイアログ作成&表示
	Acad.dlLoad "２線間の等距離or等角度分割線",,1
	Acad.dlAddLabel "", "線分選択方法", 12, 0, 1
	Acad.dlIncCurrentY -2
	Acad.dlAddLabel "", " 等距離(平行)の場合は任意", 25, 0, 1
	Acad.dlIncCurrentY -2
	Acad.dlAddLabel "", " 等角度は反時計周りで指示", 25, 2, 1
	Acad.dlAddLabel "", "分割数", 6, -1, 1
	Acad.dlAddCombo "cmb1","2|3|4|5|6|7|8|9|10|15|20", Bun, 8, -1	'使用頻度の高い数値を記入して下さい
	Acad.dlAddLabel "", "  ", 1, -1, 1
	Acad.dlAddButton "cmdRe", "再作図", 9, 2

	Acad.dlAddButton "cmdGo","線 選 択", 14, -1
	Acad.dlAddLabel "", "  ", 1, -1, 1
	Acad.dlAddButton "cmdCancel", "終　了", 9, 0
	Acad.dlShow 80,100											'ダイアログ表示
End Sub


Sub Er()
	Acad.acPostCommand "ucs^Mp^M"								'UCSを元に戻す
	If Acad.ErrNumber = vbObjectError + 1000 Then
		'キャンセル時の処理
	Else
		Acad.ShowError	'エラー内容表示
	End If
End Sub