Dim Acad
Call Main

Sub Main()
	Set Acad = CreateObject("AcadRemocon.Body")
	Acad.acGetVar "dimscale", dims
	Do
		If Not Acad.acDxfOut("_２本の線分(水平or鉛直)を選択_",,,,,4) Then Er: Exit Sub
		If Not Acad.DxfExtract(Cnt, XY, "ENTITIES", "", "LINE", "10|20|11|21") Then Er: Exit Sub
		If Cnt<>2 Then Acad.acShowMessage("線分は２本だけを選択して下さい"): Er: Exit Sub
		X1 = Acad.vbVal(XY(1, 1)): Y1 = Acad.vbVal(XY(2, 1))
		X2 = Acad.vbVal(XY(3, 1)): Y2 = Acad.vbVal(XY(4, 1))
		X3 = Acad.vbVal(XY(1, 2)): Y3 = Acad.vbVal(XY(2, 2))
		X4 = Acad.vbVal(XY(3, 2)): Y4 = Acad.vbVal(XY(4, 2))

		If X1 = X2 And X3 = X4 Then
			If Y1 > Y2 Then tmp = Y1: Y1 = Y2: Y2 = tmp
			If Y3 > Y4 Then tmp = Y3: Y3 = Y4: Y4 = tmp
			If X1 > X3 Then 
				tmp = X1: X1 = X3: X3 = tmp: tmp = X2: X2 = X4: X4 = tmp
				tmp = Y1: Y1 = Y3: Y3 = tmp: tmp = Y2: Y2 = Y4: Y4 = tmp
			End If
		Else
			If Y1 = Y2 And Y3 = Y4 Then
				If X1 > X2 Then tmp = X1: X1 = X2: X2 = tmp
				If X3 > X4 Then tmp = X3: X3 = X4: X4 = tmp
				If Y1 > Y3 Then
					tmp = Y1: Y1 = Y3: Y3 = tmp: tmp = Y2: Y2 = Y4: Y4 = tmp
					tmp = X1: X1 = X3: X3 = tmp: tmp = X2: X2 = X4: X4 = tmp
				End If
			Else
				Acad.acShowMessage("水平平行線及び垂直平行線のみです　あしからず"): Er: Exit Sub
			End If
		End If

		If Not Acad.GetInteger("ピッチ(mm)を入力", Pich, Pich) Then Er: Exit Sub

		If X1 = X2 Then
			L = X3 - X1: a = (Y3 - Y1) / L: b = (Y4 -Y2) / L
			LL = (L / Pich) - Int(L / Pich)
			If LL = 0 Then
				N = Int(L / Pich): L1 = 0: j = N - 2
				KX1 = X1: KY1 =Y1: KX2 = X2: KY2 = Y2: KX0 = X2: KY0 =Y2
			Else
				N = Int(L / Pich) - 1: L1 = (L - N * Pich) / 2: j = N-1
				KX1 = X1 +  L1: KY1 = Y1 + L1 * a: KX2 = X2 + L1: KY2 = Y2 + L1 * b
				KX0 = KX2: KY0 = KY2
				Acad.acLine KX1, KY1, KX2, KY2
			End If

			If Y2 > Y4 Then
				YY = Y2 + 30 * dims
			Else
				YY = Y4 + 30 * dims
			End If

			For i = 0 To j
				KX1 = KX1 + Pich: KY1 = KY1 + Pich * a
				KX2 = KX2 + Pich: KY2 = KY2 + Pich * b
				Acad.acLine KX1, KY1, KX2, KY2
			Next

			HKT = "t " & N & " @ " & Pich & " = <>^M"
			Acad.acGetVar "clayer", cla
			Acad.acPostCommand "^C^C-layer m D-STR-DIM^M^M"
			If LL <> 0 Then
				Acad.acPostCommand "^C^Cdimlinear "&X2&","&Y2&" "&KX0&","&KY0&" "&X2&","&YY&" "
				Acad.acPostCommand "^C^Cdimlinear "&KX0&","&KY0&" "&KX2&","&KY2&" "&HKT&KX0&","&YY&" "
				Acad.acPostCommand "^C^Cdimlinear "&KX2&","&KY2&" "&X4&","&Y4&" "&KX2&","&YY&" "
			Else
				Acad.acPostCommand "^C^Cdimlinear "&KX0&","&KY0&" "&X4&","&Y4&" "&HKT&KX0&","&YY&" "
			End If
			Acad.acPostCommand "^C^Cclayer " & cla & "^M^M"
		Else
			L = Y3 - Y1: a = (X3 - X1) / L: b = (X4 -X2) / L
			LL = (L / Pich) - Int(L / Pich)
			If LL = 0 Then
				N = Int(L / Pich): L1 = 0: j = N - 2
				KX1 = X1: KY1 = Y1: KX2 = X2: KY2 = Y2: KX0 = X2: KY0 = Y2
			Else
				N = Int(L / Pich) - 1: L1 = (L - N * Pich) / 2: j = N -1
				KX1 = X1 +  L1 * a: KY1 = Y1 + L1: KX2 = X2 + L1 * b: KY2 = Y2 + L1
				KX0 = KX2: KY0 = KY2
				Acad.acLine KX1, KY1, KX2, KY2
			End If

			If X2 > X4 Then
				XX = X2 + 30 * dims
			Else
				XX = X4 + 30 * dims
			End If

			For i = 0 To j
				KX1 = KX1 + Pich * a: KY1 = KY1 + Pich
				KX2 = KX2 + Pich * b: KY2 = KY2 + Pich
				Acad.acLine KX1, KY2, KX2, KY2
			Next
			HKT = "t " & N & " @ " & Pich & " = <>^M"
			Acad.acGetVar "clayer", cla
			Acad.acPostCommand "^C^C-layer m D-STR-DIM^M^M"
			If LL <> 0 Then
				Acad.acPostCommand "^C^Cdimlinear "&X2&","&Y2&" "&KX0&","&KY0&" v "&XX&","&Y2&" "
				Acad.acPostCommand "^C^Cdimlinear "&KX0&","&KY0&" "&KX2&","&KY2&" v "&HKT&XX&","&KY0&" "
				Acad.acPostCommand "^C^Cdimlinear "&KX2&","&KY2&" "&X4&","&Y4&" v "&XX&","&KY2&" "
			Else
				Acad.acPostCommand "^C^Cdimlinear "&KX0&","&KY0&" "&X4&","&Y4&" v "&HKT&XX&","&KY0&" "
			End If
			Acad.acPostCommand "^C^Cclayer " & cla & "^M^M"
		End If
	Loop

End Sub

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