'矢印付％勾配と法勾配の記入(ゴシック)
'2004/11/18　　　by Den

Dim Acad, Keta, hyoji
Call Main

Private Sub Main()
	Set Acad = CreateObject("AcadRemocon.Body")
	If Not Acad.CheckVersion("314") Then Exit Sub

	Acad.acGetVar "dimscale", dims
	Acad.acGetVar "dimgap", dgap: dgap=dgap*dims

	Acad.GetIniStr Keta, "Keta", "Den勾配"
	Acad.GetIniStr MH, "TextH", "Den勾配"
	Acad.GetIniStr TYH, "TYH", "Den勾配"
	Acad.GetIniStr hyoji, "hyoji", "Den勾配"
	Acad.GetIniStr LK, "LK", "Den勾配"

	Do
		DialogCreate

		Select Case hyoji
			Case "N"
				Acad.dlSetProperty "rdo2", "Value", 1
				Acad.dlSetProperty "rdo2", "ForeColor", 255
				Acad.dlSetProperty "lab4", "Visible", 0
				Acad.dlSetProperty "cmb4", "Visible", 0
			Case "P2"
				Acad.dlSetProperty "rdo3", "Value", 1
				Acad.dlSetProperty "rdo3", "ForeColor", 255
			Case Else
				Acad.dlSetProperty "rdo1", "Value", 1
				Acad.dlSetProperty "rdo1", "ForeColor", 255
		End Select
		Acad.dlSetProperty "cmb1", "text", MH
		Acad.dlSetProperty "cmb3", "text", TYH
		Acad.dlSetProperty "cmb4", "text", LK

		Do
			Acad.dlWaitEvent CtrlName, CtrlValue, CtrlListIndex
			Select Case DialogEvent(CtrlName, CtrlValue, CtrlListIndex)
				Case vbOK: Exit Do
				Case vbCancel: Er: Exit Sub
			End Select
		Loop While True

		MH = Acad.dlGetValue("cmb1")
		Keta = Acad.dlGetValue("cmb2")
		TYH = Acad.dlGetValue("cmb3")
		LK = Acad.dlGetValue("cmb4")
		Acad.PutIni Keta,"Keta","Den勾配"
		Acad.PutIni MH,"TextH","Den勾配"
		Acad.PutIni TYH,"TYH","Den勾配"
		Acad.PutIni hyoji,"hyoji","Den勾配"
		Acad.PutIni LK,"LK","Den勾配"
		Acad.dlUnload							'ダイアログアンロード

		Do
			If Not Acad.acDxfOut("【線分を選択、[Enter]でメニューへ】", "SGL", False) Then Er: Exit Do
			Acad.acPostCommand "undo^Mm^M"			'ポリラインに対応するためマークする
			Acad.acPostCommand "explode^M@^M^M"		'ポリラインを分解して線分にする
			If Not Acad.acDxfOut (, "@^M^M") Then Er: Exit Sub
			If Not Acad.DxfExtract(Cnt, XY, "ENTITIES", "", "*LINE", "10|20|11|21") Then Er: Exit Sub
			X1 = XY(1, 1)/1: Y1 = XY(2, 1)/1		'端点Aの座標抽出
			X2 = XY(3, 1)/1: Y2 = XY(4, 1)/1		'端点Bの座標抽出
			Acad.acPostCommand "undo^Mb^M"			'マーク位置に戻りポリラインに戻す

			If X1 > X2 Then						'直線の並び替え
				Tmp = X1: X1 = X2: X2 = Tmp
				Tmp = Y1: Y1 = Y2: Y2 = Tmp
			End If

			If X1 = X2 Then
				Kakudo = 0: Angle = 0
			Else
				Kakudo = Abs((Y2-Y1)/(X2-X1))
				Oangle = Atn((Y2-Y1)/(X2-X1))
				Angle = Oangle*180/Acad.PI
			End If

			X3 = ( X1 + X2 ) / 2 :Y3 = ( Y1 + Y2 ) / 2		'線分中点の計算
			X4 = Sin(Oangle)*dgap: Y4 = Cos(Oangle)*dgap	'勾配に応じた離れ

			If hyoji = "N" Then								'法勾配の場合
				If Kakudo = 0 Then
					Str1 = "Level"
				Else
					Str1 = "1:"&FormatNumber(Round(1/Kakudo*TYH,Keta),Keta)
				End If
				Acad.acText "bc", X3, Y3, MH*dims, Angle , Str1
			Else											'％勾配の場合
				If Kakudo = 0 Then
					Str1 = "Level"
				Else
					Str1 = FormatNumber(Round(Kakudo*100/TYH,Keta),Keta)&"%"
				End If
				If hyoji = "P2" then Str1 = "i=" & Str1
				Acad.acText "bc", X3-X4*2, Y3+Y4*2, MH*dims, Angle , Str1
				Ylen = (Len(Str1) + 2) * MH * dims * LK
				X5 = X3 - X4 * 2 - Cos(Oangle) * Ylen / 2
				Y5 = Y3 + Y4 * 2 - Sin(Oangle) * Ylen / 2
				X6 = X3 - X4 * 2 + Cos(Oangle) * Ylen / 2
				Y6 = Y3 + Y4 * 2 + Sin(Oangle) * Ylen / 2
				If Angle < 0 Then
					Tmp = X5: X5 = X6: X6 = Tmp
					Tmp = Y5: Y5 = Y6: Y6 = Tmp
				End If
				Acad.acPostCommand "leader^Mnon^M"&X5&","&Y5&"^Mnon^M"&X6&","&Y6&"^M^M^Mn^M"
			End If
		Loop
	Loop
End Sub

Sub DialogCreate()												'ダイアログ作成&表示
	Acad.dlLoad "勾配記入",, 1									'ダイアログ開始

	Acad.dlAddRadio "rdo1", "○○%", rd, 8, -1				'ラジオボタン
	Acad.dlAddRadio "rdo2", "1:○○", rd, 10, -1			'ラジオボタン
	Acad.dlAddRadio "rdo3", "i=○%", rd, 8, 2				'ラジオボタン

	Acad.dlAddLabel "", "　桁数", 6, -1, 1
	Acad.dlAddCombo "cmb2", "0|1|2|3|4|5|6", Keta, 6, -1
	Acad.dlAddLabel "lab4", "　係数", 6, -1, 1
	Acad.dlAddCombo "cmb4", "0.75|1.00|1.25", LK, 8, 2

	Acad.dlAddLabel "", "文字高", 6, -1, 1
	Acad.dlAddCombo "cmb1", "2.0|2.5|3.0|3.5|4.0|5.0|7.0|10.0|14.0|20.0", MH, 8, -1
	Acad.dlAddLabel "", "", 2, -1, 1
	Acad.dladdButton "cmdOK", "作　図", 10, 2

	Acad.dlAddLabel "", "縦倍率", 6, -1, 1
	Acad.dlAddCombo "cmb3", "1.0|2.0|2.5|4.0|5.0|10", TYH, 8, -1
	Acad.dlAddLabel "", "", 2, -1, 1
	Acad.dlAddButton "cmdCancel", "終　了",10,0

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

Function DialogEvent(CtrlName, CtrlValue, CtrlListIndex)		'ダイアログイベント処理
	Select Case CtrlName										'コントロール名で区別
		Case "cmdOK"											'OKボタン
			DialogEvent = vbOK
			Exit Function
		Case "cmdCancel"										'キャンセルボタン
			DialogEvent = vbCancel
			 Exit Function
		Case "rdo1"
			Acad.dlSetProperty "rdo1", "ForeColor", 255
			Acad.dlSetProperty "rdo2", "ForeColor", 0
			Acad.dlSetProperty "rdo3", "ForeColor", 0
			Acad.dlSetProperty "lab4", "Visible", 1
			Acad.dlSetProperty "cmb4", "Visible", 1
			hyoji = "P1"
		Case "rdo2"
			Acad.dlSetProperty "rdo1", "ForeColor", 0
			Acad.dlSetProperty "rdo2", "ForeColor", 255
			Acad.dlSetProperty "rdo3", "ForeColor", 0
			Acad.dlSetProperty "lab4", "Visible", 0
			Acad.dlSetProperty "cmb4", "Visible", 0
			hyoji = "N"
		Case "rdo3"
			Acad.dlSetProperty "rdo1", "ForeColor", 0
			Acad.dlSetProperty "rdo2", "ForeColor", 0
			Acad.dlSetProperty "rdo3", "ForeColor", 255
			Acad.dlSetProperty "lab4", "Visible", 1
			Acad.dlSetProperty "cmb4", "Visible", 1
			hyoji = "P2"
	End Select
    DialogEvent = vbRetry										'再度イベント待ち
End Function



Sub Er()				'エラー処理
    If Acad.ErrNumber = vbObjectError + 1000 Then
		'ユーザーによるキャンセル時の処理
	Else
		Acad.dlUnload				'エラー表示が隠れないようにダイアログアンロード
		Acad.ShowError				'エラー内容表示
	End If
End Sub