'標高旗上げ　　by Den
'2003/07/01  初版作成。
'2004/11/21  ダイアログ版作成、acPostCommandの[ ]を[^M]に変更した。
'2004/12/16  接頭文字と末尾文字を追加した。
'2005/02/13  縦倍率に対応した。
'2005/04/10  DxfOutの精度を7桁にした（書込み誤差の仮対応）
'2005/04/13  DL線にUCSを移動することで書込み誤差を解消した(DxfOutの精度は戻しました)
'2006/11/02  基準線のポリラインに対応した。[Enter]でDL指示クリックと同じ動作をするようにした。
'            引き出し方向指定時の構築線表示を止めた。
'2006/11/09  引出し方向指定時にラバーバンドを採用した。
'            矢印なしの引出し線も作図できるようにした。
'            引出し方向と引出し高さに任意を使えるようにした（角度固定で任意高、高さ固定で任意角度も可能）
'            水平、鉛直引出しに対応した（ちょっと誤魔化してますが・・・・・）
'2006/12/01  DL線の水平判定を小数以下６桁までとした。
'2006/12/03  Version2007に対応した（つもり）
'2007/02/02  基準線指示のエラー後にメニューに戻るようにした。
'            指定画層への作図を可能にした。（画層名は本VBS内29行目を変更）


Dim Acad, keta, taka, kaku, atama, usiro, Tbai, Tanni, yaji, gaso, olay
Dim dimscale, dmasz, DL, Erno
Call Main

Private Sub Main()	'メインルーチン
	Set Acad = CreateObject("AcadRemocon.Body")				'AcadRemoconの宣言　重要です(^^)v
	Acad.acGetVar "dimscale", dimscale						'AutoCADの環境変数取得
	Acad.acGetVar "dimasz", dimasz
	Acad.acSetVar "DTEXTED", 1								'2006用
	olay="D-STR-DIM"										'指定の画層名

	ARemoIN													'設定ファイルから値を取得するルーチンへ

	Do														'メインループ開始
		DialogCreate										'ダイアログ作成&表示
		Do													'イベント監視ループ
			Acad.dlWaitEvent CtrlName, CtrlValue, CtrlListIndex
			Select Case CtrlName
				Case "cmdOK"
					Exit Do
				Case "cmdCancel"
					Er: Exit Sub
				Case "cmddset"
					dset: Acad.dlShow: If Erno=0 Then Exit Do
			End Select
		Loop While True

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

		If Erno = 0 Then
			Do
				If Not Acad.acGetPoint("【測定点を指示、[Enter]でメニューへ】","",X1,Y1) Then Er: Exit Do
				If Not Acad.acGetDist("【方向を指示、[Enter]でメニューへ】","@^M",,Nkaku,,X2,Y2) Then Er: Exit Do
				If taka="任意" Then takasa=abs(Y2)/dimscale Else takasa=taka
				ZureY=dimscale*takasa										'引出し線Ｙ相対座標
				If kaku="任意" Then
					If Nkaku>270 Then
						kakudo=360-Nkaku
					ElseIf Nkaku=270 Then
						kakudo=89.9999999999
					ElseIf Nkaku>180 Then
						kakudo=Nkaku-180
					ElseIf Nkaku=180 Then
						kakudo=0.00000001
					ElseIf Nkaku>90 Then
						kakudo=180-Nkaku
					ElseIf Nkaku=90 Then
						kakudo=89.9999999999
					ElseIf Nkaku>0 Then
						kakudo=Nkaku
					Else
						kakudo=0.00000001
					End If
				Else
					kakudo=kaku
				End If
				If yaji=0 Then yoko=0 Else yoko=dimasz
				ZureX=dimscale*(takasa/tan(kakudo*Acad.PI/180)+yoko)		'引出し線Ｘ相対座標
				If X2 < 0 Then dx=X1-ZureX Else dx=X1+ZureX
				If Y2 < 0 Then dy=Y1-ZureY Else dy=Y1+ZureY
				If Tanni = "ｍｍ" Then keisu = 1000 Else keisu = 1
				H=FormatNumber(Round(Y1/Tbai/keisu+DL,keta),keta)
				Acad.acPostCommand "_dimasz " & yoko & "^M"
				If gaso=1 Then
					Acad.acPostCommand "-layer m "&olay&"^M^M"
					Acad.acPostCommand "_leader^M"&Acad.Pt(X1,Y1)&Acad.Pt(dx,dy)&"^M"&atama&H&usiro&"^M^M"
					Acad.acPostCommand "_clayer "&clayer&"^M"
				Else
					Acad.acPostCommand "_leader^M"&Acad.Pt(X1,Y1)&Acad.Pt(dx,dy)&"^M"&atama&H&usiro&"^M^M"
				End If
				Acad.acPostCommand "_dimasz " & dimasz & "^M"
			Loop
		End If
	Loop														'メインループ終了
End Sub															'メインルーチン終了


Sub DialogCreate()				'ダイアログ作成&表示
	Acad.dlLoad "標高旗上げ",,1
	Acad.dlCurrentY=-5
	Acad.dlAddLabel "", "接頭文字　　　　　末尾文字", 28, 1, 1

	Acad.dlCurrentY=12
	Acad.dlAddCombo "cmb4","|FH=|PH=|計画高=|側道高=|▽ |高さ=|水路底=", atama, 15, -1
	Acad.dlAddLabel "", "", 1, -1, 1
	Acad.dlAddCombo "cmb5","|ｍ|ｍ以上|ｍ以下|ｍ未満", usiro, 15, 1

	Acad.dlAddLabel "", "小数桁数", 9, -1, 1
	Acad.dlAddCombo "cmb1", "3|2|1|0", keta, 6, -1
	Acad.dlAddLabel "", "　縦倍率", 9, -1, 1
	Acad.dlAddCombo "cmb6", "1|2|2.5|5|10|20|25", Tbai, 7, 1

	Acad.dlAddLabel "", "旗上高さ", 9, -1, 1
	Acad.dlAddCombo "cmb2", "5|10|15|20|任意", taka, 8, -1
	Acad.dlAddLabel "", "　角度", 6, -1, 1
	Acad.dlAddCombo "cmb3", "60|45|30|任意", kaku, 8, 1

	Acad.dlAddLabel "", "作図単位", 9, -1, 1
	Acad.dlAddCombo "cmb7", "ｍｍ|Ｍ", Tanni, 8, -1
	Acad.dlAddLabel "", "", 3, -1, 1
	Acad.dlCurrentY=89
	Acad.dlAddCheck "chk1", "矢印あり", yaji, 12, 1

	Acad.dlAddLabel "", "", 2, -1, 1
	Acad.dlAddCheck "chk2", olay&"画層に作図", gaso, 28, 1

	Acad.dlAddButton "cmddset","ＤＬ指示(Enter)", 19, -1
	Acad.dlSetProperty "cmddset", "Default", True					'EnterでDL指示
	Acad.dlAddLabel "", "  ", 1, -1, 1
	Acad.dlAddButton "cmdCancel", "終　了", 11, 0

	Acad.dlSetProperty "cmb4", "ToolTipText" ,"リスト選択または直接入力"
	Acad.dlSetProperty "cmb5", "ToolTipText" ,"リスト選択または直接入力"
	Acad.dlSetProperty "cmb1", "ToolTipText" ,"リスト選択"
	Acad.dlSetProperty "cmb6", "ToolTipText" ,"リスト選択または直接入力"
	Acad.dlSetProperty "cmb2", "ToolTipText" ,"数値入力可。任意は指示点"
	Acad.dlSetProperty "cmb3", "ToolTipText" ,"数値入力可。任意は指示点"
	Acad.dlSetProperty "cmb7", "ToolTipText" ,"リスト選択"
	Acad.dlSetProperty "chk2", "ToolTipText" ,"画層変更はVBSを直接書換"

	Acad.dlShow												'ダイアログ表示
End Sub


Sub ARemoIN()		'設定ファイルの読み込み
	Acad.GetIniVal keta, "桁数", "Den標高旗上"
	Acad.GetIniStr taka, "高さ", "Den標高旗上"
	Acad.GetIniStr kaku, "角度", "Den標高旗上"
	Acad.GetIniStr atama, "接頭", "Den標高旗上"
	Acad.GetIniStr usiro, "末尾", "Den標高旗上"
	Acad.GetIniVal Tbai, "縦倍率", "Den標高旗上"
	Acad.GetIniStr Tanni, "単位", "Den標高旗上"
	Acad.GetIniVal yaji, "矢印", "Den標高旗上"
	Acad.GetIniVal gaso, "画層", "Den標高旗上"
	IF Tbai = 0 Then Tbai = 1
	IF Tanni = "" Then Tanni = "ｍｍ"
End Sub


Sub ARemoOUT()		'設定ファイルの書き出し
	keta = Acad.dlGetValue("cmb1")				'ダイアログ数値取得
	taka = Acad.dlGetValue("cmb2")
	kaku = Acad.dlGetValue("cmb3")
	atama = Acad.dlGetValue("cmb4")
	usiro = Acad.dlGetValue("cmb5")
	Tbai = Acad.dlGetValue("cmb6")
	Tanni = Acad.dlGetValue("cmb7")
	yaji= Acad.dlGetValue("chk1")
	gaso= Acad.dlGetValue("chk2")
	Acad.PutIni keta,"桁数","Den標高旗上"		'設定ファイルに保存
	Acad.PutIni taka,"高さ","Den標高旗上"
	Acad.PutIni kaku,"角度","Den標高旗上"
	Acad.PutIni atama,"接頭","Den標高旗上"
	Acad.PutIni usiro,"末尾","Den標高旗上"
	Acad.PutIni Tbai, "縦倍率", "Den標高旗上"
	Acad.PutIni Tanni,"単位","Den標高旗上"
	Acad.PutIni yaji,"矢印","Den標高旗上"
	Acad.PutIni gaso,"画層","Den標高旗上"
End Sub


Sub dset()			'DL指示のサブルーチン
	Acad.dlHide															'ダイアログ非表示
	Erno = 0															'エラーナンバーの初期化
	If Not Acad.acPostCommand("_ucs^Mw^M") Then Er: Exit Sub			'DxfOutするのでUCSをワールドに設定
	If Not Acad.acDxfOut("【基準線と数値を選択、[Enter]でメニューへ】",,,,"2000") Then Er: Erno=4: Exit Sub
	If Not Acad.DxfExtract(N, XY, "ENTITIES", "", "*TEXT", "1|10|20") Then Er: Exit Sub
	If N <> 1 Then Acad.acShowMessage("数値が二つ以上あります。"): Erno = 3: Exit Sub
	D = Acad.vbStrConv(XY(1,1),8)				'全角→半角変換
	DL=""
	For I = 1 To Len(D)							'数値のみを抽出
		D1=mid(D,I,1)
		If asc(D1)<58 And asc(D1)>44 Then DL=DL+D1
	Next
	If Not Acad.DxfExtract(N, XY, "ENTITIES", "", "LINE", "10|11|20|21") Then Er: Exit Sub
	If N = 0 Then
		If Not Acad.acPostCommand("_undo^Mm^M") Then Er: Exit Sub			'PLINE分解のためのマーク
		If Not Acad.acPostCommand("_explode^Mp^M^M") Then Er: Exit Sub		'一旦分解
		If Not Acad.acDxfOut(, "PREV",,,"2000") Then Er: Exit Sub
		If Not Acad.acPostCommand("_undo^Mb^M") Then Er: Exit Sub			'PLINE分解のためのマーク
		If Not Acad.DxfExtract(N, XY, "ENTITIES", "", "LINE", "10|11|20|21") Then Er: Exit Sub
	End If
	If N <> 1 Then Acad.acShowMessage("基準線は単一を選択して下さい。"): Erno = 1: Exit Sub
	Ynosa=round(XY(3,1)-XY(4,1),6)
	If Ynosa <> 0 Then Acad.acShowMessage("基準線が水平ではありません。"): Erno = 2:Exit Sub
	If Not Acad.acPostCommand("_ucs^Mo^M"&XY(1,1)&","&XY(3,1)&"^M") Then Er: Exit Sub	'UCSをDL位置に設定
End sub


Sub Er()			'エラー処理
	Acad.acSetVar "DTEXTED", 0									'2006専用
	Acad.acPostCommand "_ucs^Mp^M"							'UCSを元に戻す
	If Acad.ErrNumber = vbObjectError + 1000 Then
																'ユーザーによるキャンセル時の処理
	Else
		Acad.ShowError											'エラー内容表示
	End If
End Sub