VBA - Nhập trắc ngang khảo sát

[congcd4 0]

Mình có viết 1 đoạn code nhập trắc ngang khảo sát, hỏi người dùng nhập vào giá trị cao độ và khoảng cách rồi vẽ, nhưng mình không biết sử dụng vòng lặp như thế nào (vòng lặp không biết trước số lần lặp). Đoạn code của mình như sau:

 

Public tyle As Double
    Public kc As Double
    Public cd As Double
    Public diemchen As Variant, diemchenS(2) As Double
    Public diemkc(2) As Double
Public diemcd(2) As Double
Sub chondiem()
On Error Resume Next
diemchen = ThisDrawing.Utility.GetPoint(, vbCr & "Chon diem: ")
End Sub
Sub nhaptracngang()
Dim caodo As Double
Dim khoangcach As Double
'Nhap ty le
On Error Resume Next
'tyle = ThisDrawing.Utility.GetReal(vbCr & "Nhap Ty le ve: ")
tyle = 300
'chon diem goc
Call chondiem

Call nhapkc2
Call nhapcd

Dim line1 As AcadLine
Dim line2 As AcadLine
'tim diem kc


diemkc(0) = diemchen(0) + kc * 1000
diemkc(1) = diemchen(1)
diemkc(2) = diemchen(2)

diemcd(0) = diemkc(0)
diemcd(1) = diemkc(1) + cd * 1000
diemcd(2) = diemkc(2)

Set line1 = ThisDrawing.ModelSpace.AddLine(diemchen, diemkc)
Set line2 = ThisDrawing.ModelSpace.AddLine(diemkc, diemcd)

'Ghi kc cao do
Dim diemtextkc(2) As Double
Dim diemtextcd(2) As Double

diemtextkc(0) = (diemchen(0) + diemkc(0)) / 2
diemtextkc(1) = (diemchen(1) + diemkc(1)) / 2 - tyle * 3
diemtextkc(2) = (diemchen(2) + diemkc(2)) / 2

diemtextcd(0) = diemkc(0) + 1.5 * tyle / 2
diemtextcd(1) = diemkc(1) - tyle * 15
diemtextcd(2) = diemkc(2)

'tao text
Call TaoTextStyle
Dim objtextkc As AcadText, objtextcd As AcadText
Set objtextkc = ThisDrawing.ModelSpace.AddText(kc, diemtextkc, 1.5 * tyle)
objtextkc.color = 3

Set objtextcd = ThisDrawing.ModelSpace.AddText(cd, diemtextcd, 1.5 * tyle)
objtextcd.color = 2
'xoay text
Dim DblAngle As Double
DblAngle = ThisDrawing.Utility.AngleToReal(90, acDegrees)
objtextcd.Rotation = DblAngle
'Ve duong luoi
Dim line3 As AcadLine, line4 As AcadLine, line5 As AcadLine
Dim dieml2(2) As Double, dieml3(2) As Double, dieml4(2) As Double, dieml5(2) As Double
dieml2(0) = diemchen(0): dieml2(1) = diemkc(1) - 1.5 * tyle * 4: dieml2(2) = diemkc(2)
dieml3(0) = dieml2(0) + kc * 1000: dieml3(1) = dieml2(1): dieml3(2) = dieml2(2)
dieml4(0) = diemchen(0): dieml4(1) = diemkc(1) - 1.5 * tyle * 15: dieml4(2) = diemkc(2)
dieml5(0) = dieml4(0) + kc * 1000: dieml5(1) = dieml4(1): dieml5(2) = dieml4(2)
Set line3 = ThisDrawing.ModelSpace.AddLine(dieml2, dieml3)
Set line4 = ThisDrawing.ModelSpace.AddLine(dieml3, diemkc)
Set line5 = ThisDrawing.ModelSpace.AddLine(dieml5, dieml4)

End Sub

Public Sub nhapkc2()
On Error Resume Next
kc = ThisDrawing.Utility.GetReal(vbCr & "Nhap khoang cach: ")

End Sub

Public Sub nhapcd()
On Error Resume Next
cd = ThisDrawing.Utility.GetReal(vbCr & "Nhap cao do: ")
End Sub
Public Sub TaoTextStyle()
Dim TextStyleObj As AcadTextStyle
Set TextStyleObj = ActiveDocument.TextStyles.Add("small")
TextStyleObj.SetFont "Arial", False, False, 0, 0
ThisDrawing.ActiveTextStyle = TextStyleObj
End Sub

Sub main()
Call chondiem
Dim i As Integer
For i = 1 To 10 Step 1
Call nhaptracngang
diemchenS(0) = diemkc(0)
diemchenS(1) = diemkc(1)
diemchenS(2) = diemkc(2)
Next i
End Sub

Ở sub main() vì mình chưa biết trước được số lượng điểm cần nhập nên mình đặt "For i = 1 To 10 Step 1"

Bạn nào có thể cho mình biết làm cách nào để khi người dùng bấm phím ESC thì kết thúc hàm được không ạ?

 

Xin chân thành cảm ơn các bạn!

[NguyenNgocSon 43]

Dùng vòng lặp While... Wend

[dinhvantrang 151]

Bạn dùng cấu trúc này thay cho For ...Next của bạn nhé

Do While Err = 0

Call nhaptracngang

diemchenS(0) = diemkc(0)

diemchenS(1) = diemkc(1)

diemchenS(2) = diemkc(2)

Loop

[congcd4 0]

Mình làm được rồi, cảm ơn bạn rất nhiều!!

[phuquang113 4]

Mình đang cần lisp này bạn nào có cho mình xin với!