'簡易舗装　　by Den
'2008/06/27 初版作成
'2008/06/29 路面がPLINEでもOKにした

Dim Acad, olay, chk1, rdo1, rdo2, rdo3, rdo4, txt1, txt2, txt3, txt4, hoso, X(10), Y(10)
Call Main

Private Sub Main()	'メインルーチン
	Set Acad = CreateObject("AcadRemocon.Body")				'AcadRemoconの宣言　重要です(^^)v
	olay="D-DCR-HCH2"										'指定の画層名
	ARemoIN													'設定ファイルから値を取得するルーチンへ

	Do														'メインループ開始
		DialogCreate										'ダイアログ作成&表示
		Do													'イベント監視ループ
			Acad.dlWaitEvent CtrlName, CtrlValue, CtrlListIndex
			Select Case CtrlName
				Case "cmd1"
					Acad.dlSetProperty "rdo1", "Value" , 1: Acad.dlHide
					syutoku
					Acad.dlSetProperty "txt1", "Text" , hoso: Acad.dlShow
				Case "cmd2"
					Acad.dlSetProperty "rdo2", "Value" , 1: Acad.dlHide
					syutoku
					Acad.dlSetProperty "txt2", "Text" , hoso: Acad.dlShow
				Case "cmd3"
					Acad.dlSetProperty "rdo3", "Value" , 1: Acad.dlHide
					syutoku
					Acad.dlSetProperty "txt3", "Text" , hoso: Acad.dlShow
				Case "cmd4"
					Acad.dlSetProperty "rdo4", "Value" , 1: Acad.dlHide
					syutoku
					Acad.dlSetProperty "txt4", "Text" , hoso: Acad.dlShow
				Case "cmdCancel"
					Exit Sub
				Case "cmddset"
					Exit Do
			End Select
		Loop While True

		ARemoOUT				'ダイアログ数値を設定ファイルへ書き出すルーチンへ
		Acad.dlUnload			'ダイアログアンロード
		Acad.acGetVar "clayer", clayer

		If rdo1=True Then hosou=txt1
		If rdo2=True Then hosou=txt2
		If rdo3=True Then hosou=txt3
		If rdo4=True Then hosou=txt4
		dt=split(hosou, " ")
		Sou = UBound(dt)												'<<1次元配列要素数の取得>>

		If Not Acad.acPostCommand("^C^C_ucs w ") Then Er: Exit Sub		'UCSをワールドにする
		Do
			If Not Acad.acDxfOut("【路面を指示、無選択or[Enter]でメニューへ】", "SGL", , , "2000") Then Er: Exit Do
			If Not Acad.DxfExtract(cntl, ll, "ENTITIES", "", "LINE", "10|20|11|21") Then Er: Exit Sub
			If cntl<>1 Then
				If Not Acad.DxfExtract(cntp, Obj, "ENTITIES", "", "LWPOLYLINE", "8") Then Er: Exit Sub
				If cntp<>1 Then Er: Exit Do
				If Not Acad.DxfExtractGroup(GCnt, Grp, Obj(UBound(Obj, 1), 1), "10|20") Then Er: Exit Sub
			End If
			If cntl+cntp<>1 Then Er: Exit Do
			If chk1=1 Then Acad.acPostCommand "-layer m "&olay&"^M^M"		'画層変更
			If cntl=1 Then													'線分の場合
				X1=ll(1,1): Y1=ll(2,1) :X2=ll(3,1): Y2=ll(4,1)
				For j=0 to Sou
					Y1=Y1-dt(j):Y2=Y2-dt(j)
					Acad.acLine X1,Y1,X2,Y2
				Next
			Else															'PLINEの場合
				dy=0
				For j=0 to Sou
					dy=dy+dt(j)
					Acad.acPostCommand "^C^C_pline "
					For i=1 to Gcnt
						Acad.acPostCommand "non " & Grp(1,i) & "," & Grp(2,i)-dy & "^M"
					Next
					Acad.acPostCommand "^M"
				Next
			End If
			If chk1=1 Then Acad.acPostCommand "_clayer "&clayer&"^M"		'画層を戻す
			cntl=0: cntp=0
		Loop
		If Not Acad.acPostCommand("^C^C_ucs p ") Then Er: Exit Sub		'UCSを元に戻す
	Loop														'メインループ終了
End Sub															'メインルーチン終了


Sub syutoku()
	If Not Acad.acDxfOut("【路面を含めた舗装を選択、無選択or[Enter]でメニューへ】", , , , "2000") Then Er: Exit Sub
	If Not Acad.DxfExtract(cntX, xy, "ENTITIES", "", "LINE", "10|20|11|21") Then Er: Exit Sub
	If cntX=0 Then Er: Exit Sub
	Y(1)=round(xy(2,1),3)
	For i=2 to cntX
		Acad.CalcCrossPoint X(i),Y(i),xy(1,1),xy(2,1),xy(1,1),xy(2,1)-10,xy(1,i),xy(2,i),xy(3,i),xy(4,i)
		Y(i)=round(Y(i),3)
	Next
	Do 
		gyaku=0
		For i=1 To cntX-1
			If Y(i)<Y(i+1) Then
				tmp=Y(i+1): Y(i+1)=Y(i): Y(i)=tmp: gyaku=1
			End If
		Next
	Loop While gyaku<>0
	hoso = round(Y(1)-Y(2),3)
	For i=3 to cntx
		hoso=hoso & " " & round(Y(i-1)-Y(i),3)
	Next
End Sub


Sub DialogCreate()				'ダイアログ作成&表示
	Acad.dlLoad "簡易舗装作図",,1
'	Acad.dlCurrentY=2
	Acad.dlAddRadio "rdo1", "TYPE1", rdo1, 9, -1
	Acad.dlAddText "txt1", txt1, 22, -1, True
	Acad.dlAddLabel "", "", 1, -1, True
	Acad.dlAddButton "cmd1","取得", 6, 1

	Acad.dlAddRadio "rdo2", "TYPE2", rdo2, 9, -1
	Acad.dlAddText "txt2", txt2, 22, -1, True
	Acad.dlAddLabel "", "", 1, -1, True
	Acad.dlAddButton "cmd2","取得", 6, 1

	Acad.dlAddRadio "rdo3", "TYPE3", rdo3, 9, -1
	Acad.dlAddText "txt3", txt3, 22, -1, True
	Acad.dlAddLabel "", "", 1, -1, True
	Acad.dlAddButton "cmd3","取得", 6, 1

	Acad.dlAddRadio "rdo4", "TYPE4", rdo4, 9, -1
	Acad.dlAddText "txt4", txt4, 22, -1, True
	Acad.dlAddLabel "", "", 1, -1, True
	Acad.dlAddButton "cmd4","取得", 6, 1

	Acad.dlAddButton "cmddset","作 図", 7, -1
	Acad.dlSetProperty "cmddset", "Default", True					'EnterでDL指示
	Acad.dlAddLabel "", "  ", 1, -1, 1
	Acad.dlAddButton "cmdCancel", "終 了", 7, -1
	Acad.dlAddLabel "", "  ", 1, -1, 1
	Acad.dlAddCheck "chk1", olay&"画層に作図", chk1, 23, 0
	
	Acad.dlSetProperty "txt1", "ToolTipText" ,"舗装厚をスペースで区切って入力"
	Acad.dlSetProperty "txt2", "ToolTipText" ,"舗装厚をスペースで区切って入力"
	Acad.dlSetProperty "txt3", "ToolTipText" ,"舗装厚をスペースで区切って入力"
	Acad.dlSetProperty "txt4", "ToolTipText" ,"舗装厚をスペースで区切って入力"
	Acad.dlSetProperty "cmd1", "ToolTipText" ,"図面から舗装厚を取得します(PLINE不可)"
	Acad.dlSetProperty "cmd2", "ToolTipText" ,"図面から舗装厚を取得します(PLINE不可)"
	Acad.dlSetProperty "cmd3", "ToolTipText" ,"図面から舗装厚を取得します(PLINE不可)"
	Acad.dlSetProperty "cmd4", "ToolTipText" ,"図面から舗装厚を取得します(PLINE不可)"
	Acad.dlSetProperty "chk1", "ToolTipText" ,"画層変更はVBSを直接書換"
	Acad.dlShow												'ダイアログ表示
End Sub


Sub ARemoIN()		'設定ファイルの読み込み
	Acad.GetIniStr rdo1, "rdo1", "Den簡易舗装"
	Acad.GetIniStr rdo2, "rdo2", "Den簡易舗装"
	Acad.GetIniStr rdo3, "rdo3", "Den簡易舗装"
	Acad.GetIniStr rdo4, "rdo4", "Den簡易舗装"
	Acad.GetIniStr txt1, "txt1", "Den簡易舗装"
	Acad.GetIniStr txt2, "txt2", "Den簡易舗装"
	Acad.GetIniStr txt3, "txt3", "Den簡易舗装"
	Acad.GetIniStr txt4, "txt4", "Den簡易舗装"
	Acad.GetIniVal chk1, "chk1", "Den簡易舗装"
	If rdo1="" Then rdo1=False
	If rdo2="" Then rdo2=False
	If rdo3="" Then rdo3=False
	If rdo4="" Then rdo4=False
End Sub


Sub ARemoOUT()		'設定ファイルの書き出し
	rdo1 = Acad.dlGetValue("rdo1")				'ダイアログ数値取得
	rdo2 = Acad.dlGetValue("rdo2")
	rdo3 = Acad.dlGetValue("rdo3")
	rdo4 = Acad.dlGetValue("rdo4")
	txt1 = Acad.dlGetValue("txt1")
	txt2 = Acad.dlGetValue("txt2")
	txt3 = Acad.dlGetValue("txt3")
	txt4 = Acad.dlGetValue("txt4")
	chk1 = Acad.dlGetValue("chk1")
	Acad.PutIni rdo1,"rdo1","Den簡易舗装"		'設定ファイルに保存
	Acad.PutIni rdo2,"rdo2","Den簡易舗装"
	Acad.PutIni rdo3,"rdo3","Den簡易舗装"
	Acad.PutIni rdo4,"rdo4","Den簡易舗装"
	Acad.PutIni txt1,"txt1","Den簡易舗装"
	Acad.PutIni txt2,"txt2","Den簡易舗装"
	Acad.PutIni txt3,"txt3","Den簡易舗装"
	Acad.PutIni txt4,"txt4","Den簡易舗装"
	Acad.PutIni chk1,"chk1","Den簡易舗装"
End Sub


Sub Er()			'エラー処理
															'エラー時の処理
	If Acad.ErrNumber = vbObjectError + 1000 Then
															'ユーザーによるキャンセル時の処理
	Else
		Acad.ShowError										'エラー内容表示
	End If
End Sub