Đến nội dung


Hình ảnh
- - - - -

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


  • Please log in to reply
9 replies to this topic

#1 thikb219

thikb219

    biết zoom

  • Members
  • Pip
  • 18 Bài viết
Điểm đánh giá: -2 (bình thường)

Đã gửi 29 November 2013 - 08:32 AM

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

  • 0

#2 dinhvantrang

dinhvantrang

    biết lệnh copy

  • Members
  • PipPipPip
  • 117 Bài viết
Điểm đánh giá: 26 (tàm tạm)

Đã gửi 29 November 2013 - 10:03 AM

http://www.cadviet.c...inecontinue.txt

Gửi bạn tham khảo


  • 1

Thanks and Best Regards

Skype : dinhvantrang73


#3 thikb219

thikb219

    biết zoom

  • Members
  • Pip
  • 18 Bài viết
Điểm đánh giá: -2 (bình thường)

Đã gửi 29 November 2013 - 10:27 AM

Tuyệt vời cảm ơn Dinhvantrang rất nhiều mình đang rất càn cái này mà không biết làm sao  :P


  • 0

#4 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1435 Bài viết
Điểm đánh giá: 1426 (rất tốt)

Đã gửi 29 November 2013 - 10:47 AM

http://www.cadviet.c...inecontinue.txt

Gửi bạn tham khảo

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) )  )

  • 1

#5 dinhvantrang

dinhvantrang

    biết lệnh copy

  • Members
  • PipPipPip
  • 117 Bài viết
Điểm đánh giá: 26 (tàm tạm)

Đã gửi 29 November 2013 - 01:54 PM

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


  • 1

Thanks and Best Regards

Skype : dinhvantrang73


#6 thikb219

thikb219

    biết zoom

  • Members
  • Pip
  • 18 Bài viết
Điểm đánh giá: -2 (bình thường)

Đã gửi 29 November 2013 - 01:59 PM

giúp mình luôn được không híc B)


  • 0

#7 dinhvantrang

dinhvantrang

    biết lệnh copy

  • Members
  • PipPipPip
  • 117 Bài viết
Điểm đánh giá: 26 (tàm tạm)

Đã gửi 29 November 2013 - 02:27 PM

giúp mình luôn được không híc B)

Gửi bạnhttp://www.cadviet.c...econtinue_1.txt


  • 1

Thanks and Best Regards

Skype : dinhvantrang73


#8 thikb219

thikb219

    biết zoom

  • Members
  • Pip
  • 18 Bài viết
Điểm đánh giá: -2 (bình thường)

Đã gửi 03 December 2013 - 04:39 PM

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


  • 0

#9 dinhvantrang

dinhvantrang

    biết lệnh copy

  • Members
  • PipPipPip
  • 117 Bài viết
Điểm đánh giá: 26 (tàm tạm)

Đã gửi 03 December 2013 - 05:12 PM

Gửi bạn, bạn ngâm cứu thêm về các đối tượng trong Cad nữa nhé.

http://www.cadviet.c...xt_document.txt


  • 1

Thanks and Best Regards

Skype : dinhvantrang73


#10 thikb219

thikb219

    biết zoom

  • Members
  • Pip
  • 18 Bài viết
Điểm đánh giá: -2 (bình thường)

Đã gửi 04 December 2013 - 08:12 AM

ok thank bạn nhiều  :P


  • 0