'寸法値やテキスト文字の合計計算   by Den
'2006/09/02  Ver1.0
'2006/09/18  Ver1.1 uraさん改良（上書き寸法の判定）

Dim Acad,Dsty(2,50)			'寸法スタイル格納用
Call Main

Sub Main()
	Set Acad=CreateObject("AcadRemocon.Body")
	If Not Acad.CheckVersion("313") Then Exit Sub		'バージョンチェック3.1.3
'---------------------------------------------------------------------------------------
	Mgaso="D-MTR-TXT"		'書込み文字の画層(""にすると現在の画層)
	Mkiten="mr"				'文字基点
	Mhei=0.5				'文字高
	Keta= 1					'計算及び表示桁数
	dx=-0.2					'文字X方向のオフセット量
	dy=0.5					' 〃 Y方向　　　〃
	Keisu=1					'図面単位の係数（一般的には、Ｍ単位＝1、mm単位＝0.001 かな？）
'---------------------------------------------------------------------------------------
	Select Case Keta
		Case 0
			FM = "0"
		Case 1
			FM = "0.0"
		Case 2
			FM = "0.00"
		Case 3
			FM = "0.000"
		Case 4
			FM = "0.0000"
		Case 5
			FM = "0.00000"
		Case 6
			FM = "0.000000"
	End Select
	If Not Acad.acPostCommand("-layer n " & Mgaso & "^M^M") Then Er: Exit Sub'
	If Not Acad.acPostCommand("_undo be^M") Then Er: Exit Sub'

	Do
		If Not Acad.acDxfOut("【テキスト文字や寸法値を選択／右クリックで終了】") Then Er: Exit Do
		If Not Acad.DxfExtract(Cnt1, Arr, "TABLES", "", "DIMSTYLE", "2|144") Then Er: Exit Sub
		If Cnt1 = 0 Then Er: Exit Sub
		For i=1 to Cnt1
			Dsty(1,i)=Arr(1,i)						'文字スタイル名称
			Dsty(2,i)=Arr(2,i)						'各々のDIMLFAC
			If Dsty(2,i)="" Then Dsty(2,i)=1
		Next
		If Not Acad.DxfExtract(Cnt, Arr, "ENTITIES", "", "*", "1|31|42|3") Then Er: Exit Sub
		If Cnt = 0 Then Er: Exit Sub

		kei = 0
		For i=1 to Cnt
			If Arr(0,i)="DIMENSION" Then
				For j=1 to Cnt1
					If Arr(4,i)=Dsty(1,j) Then dimf=1/Dsty(2,j)
				Next
				If Arr(1,i) = "" or InStr(Arr(1,i),"<>") > 0 Then
					Arr(1,i) = Int(Arr(3,i) * dimf * keisu * 10^Keta+0.5)/10^Keta
				Else
					Arr(1,i) = Arr(1,i) * dimf * keisu
				End If
			End If
			kei = kei + Arr(1,i)
		Next

		atai = Acad.vbFormat(kei,FM)
		If Not Acad.acGetVar("VIEWCTR", CTR) Then Er: Exit Sub		'画面の中心座標を取得
		MyArray = Split(CTR, ",", -1, 1)
		X = Acad.vbVal(MyArray(0)): Y = Acad.vbVal(MyArray(1))

		Acad.acPostCommand "-text j " & Mkiten & " " & Acad.Pt(X,Y) & Mhei & "^M^M" & atai & "^M"
		If Mgaso<>"" Then Acad.acPostCommand "_change l  p la " & Mgaso & "^M^M"
		Acad.acPostCommand "_copybase^M" & Acad.Pt(X-dx, Y-dy) & "l^M^M"
		Acad.acPostCommand "_erase^Mp^M^M"
		Acad.acSendCommand "_pasteclip^M"
	Loop

	If Not Acad.acPostCommand("_undo e^M") Then Exit Sub
End Sub


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

End Sub