Chuyển đến nội dung
Diễn đàn CADViet

thikb219

Thành viên
 Xem Hồ Sơ  Xem hoạt động của họ

  • Số lượng nội dung

    14

  • Đã tham gia

  • Lần ghé thăm cuối

Bài đăng được đăng bởi thikb219

  5. Đã đăng · Trả lời báo cáo

    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

  7. Đã đăng · Trả lời báo cáo

    thank mọi người rất nhiều mình đã làm được rồi. Nhưng cho mình hỏi một vấn đề nữa nhé có cách nào mà khi mình vẽ line bằng câu lệnh "Set lineObj = ThisDrawing.ModelSpace.AddLine(Pt1, Pt2)" thì tự động copy ra 1 line nữa đến một tọa độ được mình chỉ đinh trong cad không ta?

    Rất mong được mọi người giúp đỡ

  11. Đã đăng · Trả lời báo cáo

    Chào mọi người,

    Mình có đoạn mã như bên dưới nhưng khi vẽ xong đoạn thẳng thì text có tên "STT" ghi ở cuối đoạn thẳng vừa vẽ, Bây giờ mình muốn text đó ghi ở giữa đoạn thẳng vừa vẽ không biết có cách nào không mọi người giúp đỡ với nha.

     

     

    textString =STT

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

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

    Set LineObj = ThisDrawing.ModelSpace.AddLine(basePnt, returnPnt) 

    LineObj.Update 

    With ThisDrawing
    Utility.GetEntity LineObj, pp
     
    Set line = LineObj
    Set text = .ModelSpace.AddText _
    (textString, line.EndPoint, textHeight)
    With ThisDrawing
    Utility.GetEntity LineObj, pp
     
    Set line = LineObj
    Set text = .ModelSpace.AddText _
    (textString, line.EndPoint, textHeight)

    With ThisDrawing

    Utility.GetEntity LineObj, pp

     

    Set line = LineObj

    Set text = .ModelSpace.AddText _

    (textString, line.EndPoint, textHeight)

    OI
    Set LineObj = ThisDrawing.ModelSpace.AddLine(basePnt, returnPnt) '
    returnPnt = ThisDrawing.Utility.GetPoint(, "Nhap mot diem: ") 'NHAP DIEM DAU
    basePnt = ThisDrawing.Utility.GetPoint(returnPnt, "Nhap mot diem: ") ' NHAP DIEM CUOI
    Set LineObj = ThisDrawing.ModelSpace.AddLine(basePnt, returnPnt) ' ve DOAN THANG

  12. Đã đăng · Trả lời báo cáo

    Chào mọi người mình có một vấn đề của autocad như sau xin trình bày mong mọi người giúp đỡ nha :

          

    + Trong vba cad có cách nào khi ta nhập số bất kỳ hoặc text  thì hiện ra hộp thông báo về số hoặc text ta vừa nhập không?

    + Tương tự khi ta không nhập mà chọn số hoặc text  đã có sẵn tren màn hình autocad thì cũng hiện ra msgbox thông báo các giá trị vừa được lựa chọn?

     

    Mong mọi người giúp đỡ nhà VBA hơi gà.....

    Thanks nhiều!

×