Chuyển đến nội dung
Diễn đàn CADViet
Đăng nhập để thực hiện theo  
Người theo dõi 0
thikb219

Vẽ liên tục line bằng vba cad help?

Bởi thikb219 , trong Lập trình khác

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

thikb219    2

thikb219
Đã đăng

Chào mọi người, 

Mình có một đoạn code để vẽ 1 đường thẳng như bên dưới : nhưng đoạn code đó chỉ vẽ được 1 line duy nhất, có cách nào để viết code vẽ được liên tục các đoạn line với số lần tuỳ thích và chỉ kết thúc lệnh vẽ line khi sử dụng phím "Esc" trên bàn phím không, mong mọi người giúp đỡ mình nha.

 

sub vedoanline ()

Dim returnPnt As Variant

 Dim basePnt As Variant

returnPnt = ThisDrawing.Utility.GetPoint(, "Nhap: ")

basePnt1 = ThisDrawing.Utility.GetPoint(returnPnt, "nhap: ") 

Set lineObj = ThisDrawing.ModelSpace.AddLine(basePnt1, returnPnt)

lineobj.update

end sub

 Dim returnPnt As Variant
 
 Dim returnPnt As Variant
 
 Dim returnPnt As Variant
 
 Dim returnPnt As Variant
 Dim basePnt As Variant
 Dim returnPnt As Variant
 Dim basePnt As Variant
Public Sub DOCHIEUDAI()
Dim lineObj As AcadLine
Dim VUNG As Object
Dim SOGIATRI As Integer
On Error Resume Next
Set ExcelApp = GetObject(, "Excel.Application")
Dim objlayer As AcadLayer
T = ExcelApp.ActiveCell.Row
 Dim returnPnt As Variant
 Dim basePnt As Variant
 Dim text As AcadText
Dim textString As String
Dim textHeight As Double
Dim line As AcadLine
Dim obj As AcadObject
Dim pp
' TAO LAYER TUONG UNG VOI STT O BEN EXCEL
I = ExcelApp.ActiveCell.Row
If ExcelApp.Worksheets("SHEET1").CELLS(I, 25).Value = 0 Then
Set thi1 = ActiveDocument.Layers.Add("T" & I)
ActiveDocument.ActiveLayer = ActiveDocument.Layers("T" & I)
textString = ("T" & I)
textHeight = 250
           ' VE COT 1
If ExcelApp.Worksheets("SHEET1").CELLS(T, 27).Value = 0 Then
     
returnPnt = ThisDrawing.Utility.GetPoint(, "Nhap KTCOT1: ") 'NHAP DIEM DAU
basePnt1 = ThisDrawing.Utility.GetPoint(returnPnt, "KTCOT1: ") ' NHAP DIEM CUOI
Set lineObj = ThisDrawing.ModelSpace.AddLine(basePnt1, returnPnt) ' ve DOAN THANG
              'Set lineObj = ThisDrawing.PaperSpace.AddLine(basePnt, returnPnt) ' kho cho hinh tren cad
lineObj.color = 7 ' MAU CHO LINEOBJ
lineObj.Update ' HIEN DAON THANG LINEOBJ LEN MAN HINH CAD
KTC1 = lineObj.Length ' GAN CHIEU DAI DOAN THANG BANG BIEN DAILINE
ExcelApp.Worksheets("SHEET1").CELLS(I, 31).Value = KTC1 ' GAN VAO COT 34 BEN EXCEL GIA TRI CHIEU DAI CUA LINE
End If
Public Sub DOCHIEUDAI()
Dim lineObj As AcadLine
Dim VUNG As Object
Dim SOGIATRI As Integer
On Error Resume Next
Set ExcelApp = GetObject(, "Excel.Application")
Dim objlayer As AcadLayer
T = ExcelApp.ActiveCell.Row
 Dim returnPnt As Variant
 Dim basePnt As Variant
 Dim text As AcadText
Dim textString As String
Dim textHeight As Double
Dim line As AcadLine
Dim obj As AcadObject
Dim pp
' TAO LAYER TUONG UNG VOI STT O BEN EXCEL
I = ExcelApp.ActiveCell.Row
If ExcelApp.Worksheets("SHEET1").CELLS(I, 25).Value = 0 Then
Set thi1 = ActiveDocument.Layers.Add("T" & I)
ActiveDocument.ActiveLayer = ActiveDocument.Layers("T" & I)
textString = ("T" & I)
textHeight = 250
           ' VE COT 1
If ExcelApp.Worksheets("SHEET1").CELLS(T, 27).Value = 0 Then
     
returnPnt = ThisDrawing.Utility.GetPoint(, "Nhap KTCOT1: ") 'NHAP DIEM DAU
basePnt1 = ThisDrawing.Utility.GetPoint(returnPnt, "KTCOT1: ") ' NHAP DIEM CUOI
Set lineObj = ThisDrawing.ModelSpace.AddLine(basePnt1, returnPnt) ' ve DOAN THANG
              'Set lineObj = ThisDrawing.PaperSpace.AddLine(basePnt, returnPnt) ' kho cho hinh tren cad
lineObj.color = 7 ' MAU CHO LINEOBJ
lineObj.Update ' HIEN DAON THANG LINEOBJ LEN MAN HINH CAD
KTC1 = lineObj.Length ' GAN CHIEU DAI DOAN THANG BANG BIEN DAILINE
ExcelApp.Worksheets("SHEET1").CELLS(I, 31).Value = KTC1 ' GAN VAO COT 34 BEN EXCEL GIA TRI CHIEU DAI CUA LINE
End If
Public Sub DOCHIEUDAI()
Dim lineObj As AcadLine
Dim VUNG As Object
Dim SOGIATRI As Integer
On Error Resume Next
Set ExcelApp = GetObject(, "Excel.Application")
Dim objlayer As AcadLayer
T = ExcelApp.ActiveCell.Row
 Dim returnPnt As Variant
 Dim basePnt As Variant
 Dim text As AcadText
Dim textString As String
Dim textHeight As Double
Dim line As AcadLine
Dim obj As AcadObject
Dim pp
' TAO LAYER TUONG UNG VOI STT O BEN EXCEL
I = ExcelApp.ActiveCell.Row
If ExcelApp.Worksheets("SHEET1").CELLS(I, 25).Value = 0 Then
Set thi1 = ActiveDocument.Layers.Add("T" & I)
ActiveDocument.ActiveLayer = ActiveDocument.Layers("T" & I)
textString = ("T" & I)
textHeight = 250
           ' VE COT 1
If ExcelApp.Worksheets("SHEET1").CELLS(T, 27).Value = 0 Then
     
returnPnt = ThisDrawing.Utility.GetPoint(, "Nhap KTCOT1: ") 'NHAP DIEM DAU
basePnt1 = ThisDrawing.Utility.GetPoint(returnPnt, "KTCOT1: ") ' NHAP DIEM CUOI
Set lineObj = ThisDrawing.ModelSpace.AddLine(basePnt1, returnPnt) ' ve DOAN THANG
              'Set lineObj = ThisDrawing.PaperSpace.AddLine(basePnt, returnPnt) ' kho cho hinh tren cad
lineObj.color = 7 ' MAU CHO LINEOBJ
lineObj.Update ' HIEN DAON THANG LINEOBJ LEN MAN HINH CAD
KTC1 = lineObj.Length ' GAN CHIEU DAI DOAN THANG BANG BIEN DAILINE
ExcelApp.Worksheets("SHEET1").CELLS(I, 31).Value = KTC1 ' GAN VAO COT 34 BEN EXCEL GIA TRI CHIEU DAI CUA LINE
End If
Public Sub DOCHIEUDAI()
Dim lineObj As AcadLine
Dim VUNG As Object
Dim SOGIATRI As Integer
On Error Resume Next
Set ExcelApp = GetObject(, "Excel.Application")
Dim objlayer As AcadLayer
T = ExcelApp.ActiveCell.Row
 Dim returnPnt As Variant
 Dim basePnt As Variant
 Dim text As AcadText
Dim textString As String
Dim textHeight As Double
Dim line As AcadLine
Dim obj As AcadObject
Dim pp
' TAO LAYER TUONG UNG VOI STT O BEN EXCEL
I = ExcelApp.ActiveCell.Row
If ExcelApp.Worksheets("SHEET1").CELLS(I, 25).Value = 0 Then
Set thi1 = ActiveDocument.Layers.Add("T" & I)
ActiveDocument.ActiveLayer = ActiveDocument.Layers("T" & I)
textString = ("T" & I)
textHeight = 250
           ' VE COT 1
If ExcelApp.Worksheets("SHEET1").CELLS(T, 27).Value = 0 Then
     
returnPnt = ThisDrawing.Utility.GetPoint(, "Nhap KTCOT1: ") 'NHAP DIEM DAU
basePnt1 = ThisDrawing.Utility.GetPoint(returnPnt, "KTCOT1: ") ' NHAP DIEM CUOI
Set lineObj = ThisDrawing.ModelSpace.AddLine(basePnt1, returnPnt) ' ve DOAN THANG
              'Set lineObj = ThisDrawing.PaperSpace.AddLine(basePnt, returnPnt) ' kho cho hinh tren cad
lineObj.color = 7 ' MAU CHO LINEOBJ
lineObj.Update ' HIEN DAON THANG LINEOBJ LEN MAN HINH CAD
KTC1 = lineObj.Length ' GAN CHIEU DAI DOAN THANG BANG BIEN DAILINE
ExcelApp.Worksheets("SHEET1").CELLS(I, 31).Value = KTC1 ' GAN VAO COT 34 BEN EXCEL GIA TRI CHIEU DAI CUA LINE
End If

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

gia_bach    1.531

gia_bach
Đã đăng

T/hợp bản vẽ 3D (có cao độ Z) cần thêm StartPnt(2) = P2(2)

 

Nhưng tại sao phải thêm biến StartPnt ?

Sub AddMultiLine()
    On Error Resume Next

    Dim pt1 As Variant
    Dim pt2 As Variant
    Dim lineObj As AcadLine

    pt1 = ThisDrawing.Utility.GetPoint(, "diem dau : ")
    Do
        pt2 = ThisDrawing.Utility.GetPoint(pt1, "diem cuoi: ")
        If Err Then Exit Sub
        Set lineObj = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
        pt1 = pt2
    Loop

End Sub

 

(defun c:test(/ start end num)
  (setq start 2 end 7)
  (while
    (not
      (and
(setq num (getint (strcat "Nhap so trong khoang <" (itoa start)  " ~ " (itoa end)">")))
(< start num end ) ) )
    (princ "\nGia tri khong hop le. Nhap lai! ")    )
  (alert (strcat "Gia tri : " (itoa num) )  )
 
(defun c:test(/ start end num)
  (setq start 2 end 7)
  (while
    (not
      (and
(setq num (getint (strcat "Nhap so trong khoang <" (itoa start)  " ~ " (itoa end)">")))
(< start num end ) ) )
    (princ "\nGia tri khong hop le. Nhap lai! ")    )
  (alert (strcat "Gia tri : " (itoa num) )  )
  • 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

dinhvantrang    151

dinhvantrang
Đã đăng

Các bạn cho minh hỏi có cách nào để đếm được luôn số lần mình vẽ không ví dụ mình vẽ 10 đoạn line thì cho số lần là 10 luôn

Bạn thêm vào một biến đếm trong vòng lặp nữa

  • 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

thikb219    2

thikb219
Đã đăng

Thank pác dinhvantrang nhiều dinhvantrang cho mình hỏi có cách nào mình cho nó hiện thông báo tổng chiều dài các đoạn vừa vẽ lên được không dinhvantrang? rất mong nhận được sự giúp đỡ của dinhvantrang và mọi người trên diễn đà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

ngoduyhung    0

ngoduyhung
Đã đăng

@dinhvantrang

Mình muốn vẽ đo kích thước liên tục có ngắt giữa các lần mình làm thế này nhưng không được

  Dim point1 As Variant
    Dim point2 As Variant
    Dim location(0 To 2) As Double
    ' Return a point, no prompt
    point1 = ThisDrawing.Utility.GetPoint(, "diem dau: ")
    
  
    
    point2 = ThisDrawing.Utility.GetPoint(, "diem cuoi: ")
    Set objss = ThisDrawing.ModelSpace.AddDimAligned(point1, point2, location)

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    151

dinhvantrang
Đã đăng 
Sub Test()
    Dim point1 As Variant
    Dim point2 As Variant
    Dim location(0 To 2) As Double
    ' Return a point, no prompt
    point1 = ThisDrawing.Utility.GetPoint(, "diem dau: ")
    On Error GoTo Endsub
    Do While Err = 0
        
        
        point2 = ThisDrawing.Utility.GetPoint(point1, "diem ke tiep: ")
        z e
        Set objss = ThisDrawing.ModelSpace.AddDimAligned(point1, point2, location)
        point1 = point2
        
    Loop
Endsub:
    Err.Clear
    
End Sub

Gửi bạn nhé

  • 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  
Người theo dõi 0
Về Đầu Trang Lập trình khác
×