Chuyển đến nội dung
Diễn đàn CADViet
  • Thông báo

    • Nguyen Hoanh

      CADViet đã hoàn tất nâng cấp   14/09/2017

      Chào các bạn, CADViet đã hoàn tất việc nâng cấp lên phiên bản mới. Tất cả các chức năng đã hoạt động theo kỳ vọng của ban quản trị. Nếu có vấn đề gì cần phản hồi, các bản post ở đây nhé: Trân trọng, Nguyễn Hoành.
Đăng nhập để thực hiện theo  
congcd4

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

Các bài được khuyến nghị

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!

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
dinhvantrang    64

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

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay

Đăng nhập để thực hiện theo  

×