'VCL作図
'2004/12/17　　　by Den

Dim Acad													'これは必ず宣言
Dim VCL, SV, SH, MH, ST, dims								'使用する変数を記入
Call Main													'メインルーチン呼出し

Private Sub Main()											'メインルーチン開始
	Set Acad = CreateObject("AcadRemocon.Body")				'AcadRemoconの宣言　重要です(^^♪
	Acad.acGetVar "dimscale", dims							'AutoCADの環境変数取得
	Acad.acGetVar "dimgap", dgap
	Acad.GetIniVal VCL, "VCL", "DenVCL"						'AcadRemoconの設定ファイルから値を取得
	Acad.GetIniVal SV, "ScaleV", "DenVCL"
	Acad.GetIniVal SH, "ScaleH", "DenVCL"
	Acad.GetIniVal MH, "TextH", "DenVCL"
	Acad.GetIniStr ST, "Tanni", "DenVCL"

	Do																		'メインループ開始
		DialogCreate														'ダイアログ作成&表示
		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														'イベント監視ループ終了

		VCL = Acad.dlGetValue("cmb1")
		SV = Acad.dlGetValue("cmb2")
		SH = Acad.dlGetValue("cmb3")
		MH = Acad.dlGetValue("cmb4")
		ST = Acad.dlGetValue("cmb5")
		Acad.PutIni VCL,"VCL", "DenVCL"
		Acad.PutIni SV,"ScaleV", "DenVCL"
		Acad.PutIni SH,"ScaleH", "DenVCL"
		Acad.PutIni MH,"TextH", "DenVCL"
		Acad.PutIni ST,"Tanni", "DenVCL"
		Acad.dlUnload								'ダイアログアンロード

		Acad.acPostCommand "^C^Cucs^Mw^M"			'UCSをワールド座標にする
		Do																	'サブループ開始
			If Not Acad.acDxfOut("【勾配線を選択、[Enter]でメニューへ】", "", False) Then Er: Exit Do
			If Not Acad.DxfExtract(N, EP, "ENTITIES", "", "LINE", "10|11|20|21|8|6|62|370") Then Er: Exit Sub
			If N <> 2 Then Acad.acShowMessage("線分は２本のみ選択してください"): Er: Exit Do

			LA=EP(5,1)
			LT=EP(6,1)
			If LT="" Then LT="ByLayer"
			CO=EP(7,1)
			If CO="" Then CO="ByLayer" Else CO=Acad.vbVal(CO)
			LW=EP(8,1)
			Select Case LW
				Case ""
					LW="ByLayer"
				Case "    -2"
					LW="ByBlock"
				Case "    -3"
					LW="Default"
				Case Else
					LW=LW/100
			End Select

			For I=1 to 2
				For N=1 to 4
					EP(N,I)=Acad.vbVal(EP(N,I))
				Next
			Next

			If EP(1,1)<EP(2,1) Then									'線分１のソート
				X1=EP(1,1): Y1=EP(3,1): X3=EP(2,1): Y3=EP(4,1)
			Else
				X1=EP(2,1): Y1=EP(4,1): X3=EP(1,1): Y3=EP(3,1)
			End If

			If EP(1,2)<EP(2,2) Then									'線分２のソート
				X4=EP(1,2): Y4=EP(3,2): X5=EP(2,2): Y5=EP(4,2)
			Else
				X4=EP(2,2): Y4=EP(4,2): X5=EP(1,2): Y5=EP(3,2)
			End If

			If X4<X1 Then											'全体のソート
				X5=X3: Y5=Y3: X3=X1: Y3=Y1: X1=X4: Y1=Y4
			End If

			If ST="ｍｍ" Then LL=1000 Else LL=1
			VL=VCL*LL
			KKK=SH/SV: L1=X3-X1: L2=X5-X3
			i1=(Y3-Y1)/L1/KKK: i2=(Y5-Y3)/L2/KKK
			X2=X3-VL/2: Y2=Y3-VL/2*i1*KKK: X4=X3+VL/2: Y4=Y3+VL/2*i2*KKK
			Y7=(i2-i1)/8*VL*KKK
			If Y7<=0 Then
				Y6=Y3-30*dims
			Else
				Y6=Y3+30*dims
			End If

			Acad.acPostCommand "Pline^M"&Acad.Pt(X2,Y2)&Acad.Pt(X2,Y6)&Acad.Pt(X4,Y6)&Acad.Pt(X4,Y4)
			Moji="VCL="&acad.VbFormat(VCL,"0.00")
			Acad.acText "bc",X3,Y6+dgap*dims,MH*dims,0,Moji
			Moji="R="&acad.VbFormat(int(VCL/Abs(i2-i1)/10+0.9)*10,"0")
			Acad.acText "tc",X3,Y6-dgap*dims,MH*dims,0,Moji
			Acad.acPostCommand "arc^M"&X2&","&Y2&"^M"&X3&","&(Y3+Y7)&"^M"&X4&","&Y4&"^M"
			Acad.acPostCommand "chprop^Ml^M^Mla^M"&LA&"^Mlt^M"&LT&"^Mc^M"&CO&"^Mlw^M"&LW&"^M^M"

			Moji="i="&Acad.VbFormat(int(Abs(i1)*100000+0.9)/1000,"0.000")&"% L="
			Moji=moji&Acad.VbFormat(int(L1/LL*1000+0.9)/1000,"0.000")
			Kaku=Atn((Y3-Y1)/L1)*180/Acad.PI
			Acad.acText "bc",(X1+X3)/2,(Y1+Y3)/2+dgap*dims,MH*dims,Kaku,Moji
			Moji="i="&Acad.VbFormat(int(Abs(i2)*100000+0.9)/1000,"0.000")&"%"
			Moji=moji & " L=" & Acad.VbFormat(int(L2/LL*1000+0.9)/1000,"0.000")
			Kaku=Atn((Y5-Y3)/L2)*180/Acad.PI
			Acad.acText "bc",(X3+X5)/2,(Y3+Y5)/2+dgap*dims,MH*dims,Kaku,Moji
		Loop															'サブループ終了
	Loop															'メインループ終了
End Sub															'メインルーチン終了


Sub DialogCreate()											'ダイアログ作成&表示
	Acad.dlLoad "VCL作成",,1

	Acad.dlAddLabel "", "VCL=", 4, -1, 1
	Acad.dlAddCombo "cmb1", "20|25|30|35|40|50|60", VCL, 8, -1
	Acad.dlAddLabel "", "  文字高さ＝", 12, -1, 1
	Acad.dlAddCombo "cmb4", "2.0|2.5|3.0|3.5|4.0|5.0|7.0|10.0|14.0|20.0", MH, 8, 2

	Acad.dlAddLabel "", "V=1/", 4, -1, 1
	Acad.dlAddCombo "cmb2", "50|100|200|500", SV, 8, -1
	Acad.dlAddLabel "", "  作図単位＝", 12, -1, 1
	Acad.dlAddCombo "cmb5", "ｍｍ|Ｍ", ST, 8, 2

	Acad.dlAddLabel "", "H=1/", 4, -1, 1
	Acad.dlAddCombo "cmb3", "500|1000|2500|5000", SH, 8, -1
	Acad.dlAddLabel "", "  ", 2, -1, 1
	Acad.dlAddButton "cmdOK", "VCL作図", 11, -1
	Acad.dlAddLabel "", " ", 1, -1, 1
	Acad.dlAddButton "cmdCancel", "終了",6,-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
	End Select
    DialogEvent = vbRetry										'再度イベント待ち
End Function


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