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

VBA ghi text vao giữa đoạn thẳng vừa vẽ

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ó đ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

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

Hàm lấy trung điểm của 2 điểm :

Public Function MidPoint(ByVal Point1 As Variant, ByVal Point2 As Variant) As Variant

    On Error Resume Next
    Dim midpt() As Double
    
    If UBound(Point1) = 1 Then
        ReDim midpt(1)
    Else
        ReDim midpt(2)
    End If
    
    midpt(0) = (Point1(0) + Point2(0)) / 2
    midpt(1) = (Point1(1) + Point2(1)) / 2
    
    If UBound(midpt) = 2 Then
        midpt(2) = (Point1(2) + Point2(2)) / 2
    End If
    MidPoint = midpt
End Function

Sử dụng :  

Set text = .ModelSpace.AddText(TextString, MidPoint(basePnt, returnPnt), TextHeight)

With ThisDrawing
Utility.GetEntity LineObj, pp
 
Set line = LineObj
Set text = .ModelSpace.AddText(TextString, MidPoint(basePnt, returnPnt), TextHeight)
  • 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

bạn xem dùm sao cái "Set text = .ModelSpace.AddText(TextString, MidPoint(basePnt, returnPnt), TextHeight)" bị lỗi tại chỗ MidPoint(basePnt, returnPnt),  không biết sao không chay được

xem lại giúp mình với nha

 

thank!

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

bạn xem dùm sao cái "Set text = .ModelSpace.AddText(TextString, MidPoint(basePnt, returnPnt), TextHeight)" bị lỗi tại chỗ MidPoint(basePnt, returnPnt),  không biết sao không chay được

xem lại giúp mình với nha

 

thank!

Do bạn không đưa code nên khó đoán chính xác được lỗi gì?

Tuy nhiên có thể là do lỗi khai báo kiểu dữ liệu không thống nhất.

Sub AddTextMidPoint()
    On Error Resume Next

    Dim pt1 As Variant
    Dim pt2 As Variant
    Dim lineObj As AcadLine
    Dim textObj As AcadText

    pt1 = ThisDrawing.Utility.GetPoint(, "diem dau : ")
    pt2 = ThisDrawing.Utility.GetPoint(pt1, "diem cuoi: ")

    Set lineObj = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
    Set textObj = ThisDrawing.ModelSpace.AddText("Mid Point", MidPoint(pt1, pt2), lineObj.Length / 20)
End Sub
  • 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

Gửi bạn nè: 

 

http://www.cadviet.com/upfiles/3/37575_addtext.txt

Sub AddTextMidPoint()
    On Error Resume Next
    Dim StrText As String
    StrText = ThisDrawing.Utility.GetString(True, vbCrLf & "Input Text")
    Dim Pt1 As Variant
    Dim Pt2 As Variant
    Dim lineObj As AcadLine
    Dim textObj As AcadText
    Dim TxtPnt(2) As Double
    Pt1 = ThisDrawing.Utility.GetPoint(, "diem dau : ")
    Pt2 = ThisDrawing.Utility.GetPoint(Pt1, "diem cuoi: ")
    TxtPnt(0) = 0.5 * (Pt1(0) + Pt2(0))
    TxtPnt(1) = 0.5 * (Pt1(1) + Pt2(1))
    TxtPnt(2) = 0.5 * (Pt1(2) + Pt2(2))
    Set lineObj = ThisDrawing.ModelSpace.AddLine(Pt1, Pt2)
    Set textObj = ThisDrawing.ModelSpace.AddText(StrText, TxtPnt, lineObj.Length / 20)
    textObj.Alignment = acAlignmentMiddleCenter
    textObj.TextAlignmentPoint = TxtPnt
End Sub
Sub AddTextMidPoint()
    On Error Resume Next
    Dim StrText As String
    StrText = ThisDrawing.Utility.GetString(True, vbCrLf & "Input Text")
    Dim Pt1 As Variant
    Dim Pt2 As Variant
    Dim lineObj As AcadLine
    Dim textObj As AcadText
    Dim TxtPnt(2) As Double
    Pt1 = ThisDrawing.Utility.GetPoint(, "diem dau : ")
    Pt2 = ThisDrawing.Utility.GetPoint(Pt1, "diem cuoi: ")
    TxtPnt(0) = 0.5 * (Pt1(0) + Pt2(0))
    TxtPnt(1) = 0.5 * (Pt1(1) + Pt2(1))
    TxtPnt(2) = 0.5 * (Pt1(2) + Pt2(2))
    Set lineObj = ThisDrawing.ModelSpace.AddLine(Pt1, Pt2)
    Set textObj = ThisDrawing.ModelSpace.AddText(StrText, TxtPnt, lineObj.Length / 20)
    textObj.Alignment = acAlignmentMiddleCenter
    textObj.TextAlignmentPoint = TxtPnt
End Sub
  • 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

Bạn xem lại dùm mình copy nguyên đoạn mã trên vô mà vẫn không chạy được vẫn báo lối "MidPoint" híc

Do bạn chưa copy cái Function MidPoint của gia_bach nữa, nên nó báo lỗi cái chương trình của bạn chưa khai báo hàm MidPoint chứ sao.

Bạn Copy cái Function đó nữa đi rùi chạy là ok, hoặc sử dụng cái code của mình đưa lên cũng dc

  • 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 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 đỡ

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

Gửi bạn phần ví dụ trong Help của AutoCad để tham khảo nhé.Bạn chú ý trong cái code này, do phương thức Copy sẽ tạo ra một đối tượng đường tròn giống hệt  và nằm đè lên đối tượng cũ do đó chúng ta phải dùng thêm phương thức Move để di chuyển nó sang toạ độ khác.Chúc bạn thành công!

Sub Example_Copy()
' This example creates a circle and then copies
' that circle. The new circle is then moved.

' Create the circle
Dim circleObj As AcadCircle
Dim center(0 To 2) As Double
Dim radius As Double
center(0) = 2#: center(1) = 2#: center(2) = 0#
radius = 0.5
Set circleObj = ThisDrawing.ModelSpace.AddCircle(center, radius)
ZoomAll
MsgBox "Copy the circle.", , "Copy Example"

' Copy the circle
Dim copyCircleObj As AcadCircle
Set copyCircleObj = circleObj.Copy()

' Define the points that make up the move vector
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
point1(0) = 0: point1(1) = 0: point1(2) = 0
point2(0) = 2: point2(1) = 0: point2(2) = 0

MsgBox "Move the copied circle 2 units in the X direction.", , "Copy Example"

' Move the circle and color it
copyCircleObj.Move point1, point2

ZoomAll
MsgBox "Move completed.", , "Copy Example"

End Sub

  • 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

phuong44e1    2

phuong44e1
Đã đăng

 

Gửi bạn nè: 

 

http://www.cadviet.com/upfiles/3/37575_addtext.txt

Sub AddTextMidPoint()
    On Error Resume Next
    Dim StrText As String
    StrText = ThisDrawing.Utility.GetString(True, vbCrLf & "Input Text")
    Dim Pt1 As Variant
    Dim Pt2 As Variant
    Dim lineObj As AcadLine
    Dim textObj As AcadText
    Dim TxtPnt(2) As Double
    Pt1 = ThisDrawing.Utility.GetPoint(, "diem dau : ")
    Pt2 = ThisDrawing.Utility.GetPoint(Pt1, "diem cuoi: ")
    TxtPnt(0) = 0.5 * (Pt1(0) + Pt2(0))
    TxtPnt(1) = 0.5 * (Pt1(1) + Pt2(1))
    TxtPnt(2) = 0.5 * (Pt1(2) + Pt2(2))
    Set lineObj = ThisDrawing.ModelSpace.AddLine(Pt1, Pt2)
    Set textObj = ThisDrawing.ModelSpace.AddText(StrText, TxtPnt, lineObj.Length / 20)
    textObj.Alignment = acAlignmentMiddleCenter
    textObj.TextAlignmentPoint = TxtPnt
End Sub
Sub AddTextMidPoint()
    On Error Resume Next
    Dim StrText As String
    StrText = ThisDrawing.Utility.GetString(True, vbCrLf & "Input Text")
    Dim Pt1 As Variant
    Dim Pt2 As Variant
    Dim lineObj As AcadLine
    Dim textObj As AcadText
    Dim TxtPnt(2) As Double
    Pt1 = ThisDrawing.Utility.GetPoint(, "diem dau : ")
    Pt2 = ThisDrawing.Utility.GetPoint(Pt1, "diem cuoi: ")
    TxtPnt(0) = 0.5 * (Pt1(0) + Pt2(0))
    TxtPnt(1) = 0.5 * (Pt1(1) + Pt2(1))
    TxtPnt(2) = 0.5 * (Pt1(2) + Pt2(2))
    Set lineObj = ThisDrawing.ModelSpace.AddLine(Pt1, Pt2)
    Set textObj = ThisDrawing.ModelSpace.AddText(StrText, TxtPnt, lineObj.Length / 20)
    textObj.Alignment = acAlignmentMiddleCenter
    textObj.TextAlignmentPoint = TxtPnt
End Sub

 

May quá gặp dc người đây rồi

Mình đang gặp rắc rối chỗ này. Ở đây thì bạn vẽ line với 2 điểm pt1, pt2 được chọn sau đó gán text với toa độ điểm chèn xác định từ pt1, pt2

Vậy cho mình hỏi nếu line, pl này đã có sẵn thì làm sao để mình lấy dc tọa độ điểm đầu, giữa, cuối của nó để xác định điểm chèn.

Cảm ơn bạn nhiều.

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

phuong44e1    2

phuong44e1
Đã đăng

May quá gặp dc người đây rồi

Mình đang gặp rắc rối chỗ này. Ở đây thì bạn vẽ line với 2 điểm pt1, pt2 được chọn sau đó gán text với toa độ điểm chèn xác định từ pt1, pt2

Vậy cho mình hỏi nếu line, pl này đã có sẵn thì làm sao để mình lấy dc tọa độ điểm đầu, giữa, cuối của nó để xác định điểm chèn.

Cảm ơn bạn nhiều.

Có ai giúp tôi dc không?

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

May quá gặp dc người đây rồi

Mình đang gặp rắc rối chỗ này. Ở đây thì bạn vẽ line với 2 điểm pt1, pt2 được chọn sau đó gán text với toa độ điểm chèn xác định từ pt1, pt2

Vậy cho mình hỏi nếu line, pl này đã có sẵn thì làm sao để mình lấy dc tọa độ điểm đầu, giữa, cuối của nó để xác định điểm chèn.

Cảm ơn bạn nhiều.

bạn muốn chọn được đối tượng Line/Polyline có sẵn thì phải tạo ra một tập chọn để chưa các đối tượng đó ---> sau đó lặp qua từng phần tử Line/Polyline trong tập chọn để lấy đc điểm đầu, điểm cuối >>> AddText bình thường thôi bạn à

  • 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

phuong44e1    2

phuong44e1
Đã đăng

bạn muốn chọn được đối tượng Line/Polyline có sẵn thì phải tạo ra một tập chọn để chưa các đối tượng đó ---> sau đó lặp qua từng phần tử Line/Polyline trong tập chọn để lấy đc điểm đầu, điểm cuối >>> AddText bình thường thôi bạn à

Bạn có thể giúp mình cái hàm để get cái điểm đó dc không, như trong lisp thì nó nó là (vlax-curve-getstartpoint obj) , (vlax-curve-getndpoint obj) còn không biết VBA nó là thế nào vậy 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

phuong44e1    2

phuong44e1
Đã đăng

có ai giúp mình được vụ getstartpoint, midpoint, endpoint của line, pl bằng vba không?

Những đối tượng này là có sẵn rồi, trong lisp thi nó dùng vlax-curve-getstartpoind, vlax-curve-getendpoind,

Cảm ơn mọi người

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

ndtnv    473

ndtnv
Đã đăng

Các hàm lấy điểm đầu, cuối:

 

Dim lineObj As AcadLine

lineObj.StartPoint và lineObj.EndPoint

 

Các hàm lấy tọa độ đỉnh pline:

 

Dim plineObj As AcadPolyline

plineObj.Coordinates và plineObj.Coordinate(index)

 

Bạn xem help phần:

- ActiveX and VBA Reference - Objects - Line object & Polyline object

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

phuong44e1    2

phuong44e1
Đã đăng

Các hàm lấy điểm đầu, cuối:

 

Dim lineObj As AcadLine

lineObj.StartPoint và lineObj.EndPoint

 

Các hàm lấy tọa độ đỉnh pline:

 

Dim plineObj As AcadPolyline

plineObj.Coordinates và plineObj.Coordinate(index)

 

Bạn xem help phần:

- ActiveX and VBA Reference - Objects - Line object & Polyline object

Cảm ơn bạn nhưng mình làm mà nó vẫn báo lỗi

Dim entObj =AcadObject

if entObj .ObjectName = "AcDbPolyline" then

Set dttext = ThisDrawing.Modelspace.AddText (txt1, entObject.Coordinates, tHeight)

Làm thế này thì nó báo lỗi nhưn nếu mình làm như sau

if entObj .ObjectName = "AcDbPolyline" then

pt = ThisDrawing.Ultilyti.Getpoint (,"Select point to add:")

Set dttext = ThisDrawing.Modelspace.AddText (txt1, pt1, tHeight)

Thì nó lại cho add text nhưng phải tự pick chọn điểm và không tự động chọn điểm đầu PL nữa

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

Code cho bạn t/hợp đường thẳng, t/hợp Poyline tự ngâm cứu nhé.

Public Sub AddTextToMidPoint()
    On Error Resume Next
    Dim objEntity As AcadEntity
    Dim varPick As Variant
    Dim lineObj As AcadLine
    Dim plineObj As AcadLWPolyline
    Dim staPt As Variant
    Dim midPt As Variant
    Dim length As Double
    Dim ang As Double
    ThisDrawing.Utility.GetEntity objEntity, varPick, "Select an entity"
    If objEntity Is Nothing Then
        MsgBox "No entity was selected"
        Exit Sub ' exit if no entity picked
    End If
    
    If objEntity.ObjectName = "AcDbLine" Then
        Set lineObj = objEntity
        staPt = lineObj.StartPoint
        length = lineObj.length
        ang = lineObj.Angle
        midPt = ThisDrawing.Utility.PolarPoint(staPt, ang, length / 2)
        
        Set textObj = ThisDrawing.ModelSpace.AddText(ThisDrawing.Utility.RealToString(length, 2, 2), midPt, length / 20)
        textObj.Rotation = ang
    ElseIf objEntity.ObjectName = "AcDbPolyline" Then
        Set plineObj = objEntity
        ' self study
    End If

End Sub
  • 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

phuong44e1    2

phuong44e1
Đã đăng

 

Code cho bạn t/hợp đường thẳng, t/hợp Poyline tự ngâm cứu nhé.

Public Sub AddTextToMidPoint()
    On Error Resume Next
    Dim objEntity As AcadEntity
    Dim varPick As Variant
    Dim lineObj As AcadLine
    Dim plineObj As AcadLWPolyline
    Dim staPt As Variant
    Dim midPt As Variant
    Dim length As Double
    Dim ang As Double
    ThisDrawing.Utility.GetEntity objEntity, varPick, "Select an entity"
    If objEntity Is Nothing Then
        MsgBox "No entity was selected"
        Exit Sub ' exit if no entity picked
    End If
    
    If objEntity.ObjectName = "AcDbLine" Then
        Set lineObj = objEntity
        staPt = lineObj.StartPoint
        length = lineObj.length
        ang = lineObj.Angle
        midPt = ThisDrawing.Utility.PolarPoint(staPt, ang, length / 2)
        
        Set textObj = ThisDrawing.ModelSpace.AddText(ThisDrawing.Utility.RealToString(length, 2, 2), midPt, length / 20)
        textObj.Rotation = ang
    ElseIf objEntity.ObjectName = "AcDbPolyline" Then
        Set plineObj = objEntity
        ' self study
    End If

End Sub

cảm ơn bạn nhiều. rất hữu ích

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

bạn gia_bach xem giúp mình cái file này với.

Nó toàn báo "no entity was select"

http://www.cadviet.com/upfiles/5/128366_test_add_text_to_line_1.rar

Thêm Hide và Show hộp thoại ở đầu và cuối Sub :

Private Sub CommandButton1_Click()
    UserForm1.Hide
    '................
    ThisDrawing.Regen acAllViewports
    UserForm1.show
End Sub
  • 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

phuong44e1    2

phuong44e1
Đã đăng

 

Thêm Hide và Show hộp thoại ở đầu và cuối Sub :

Private Sub CommandButton1_Click()
    UserForm1.Hide
    '................
    ThisDrawing.Regen acAllViewports
    UserForm1.show
End Sub

Mình đã làm dc. Cảm ơn bạn, cảm ơ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

phuong44e1    2

phuong44e1
Đã đăng

Mình đã làm dc. Cảm ơn bạn, cảm ơn diễn đàn

Dim objEntity As AcadEntity
    Dim varPick As Variant
    Dim lineobj As AcadLine
    Dim plineobj As AcadLWPolyline
    Dim Stapt As Variant
    Dim Midpt As Variant
    Dim Endpt As Variant
    Dim length As Double
    Dim ang As Double
    Dim txt1 As String
    Dim Index As Integer
    Dim textobj As AcadText
    ThisDrawing.Utility.GetEntity objEntity, varPick, "Select an entity"
If objEntity Is Nothing Then
    MsgBox " No entity was select"
    Exit Sub
End If
If objEntity.ObjectnName = "AcDbLine" Then
   .............
Else
If objEntity.ObjectnName = "AcDbPolyLine" Then
    Set plineobj = objEntity
    Stapt = plineobj.Coordinate(Index)
    length = plineobj.length
    txt1 = ThisDrawing.Utility.RealToString(length, 2, 2)
    Set textobj = ThisDrawing.ModelSpace.AddText(txt1, Stapt, length / 20)
Else
Exit Sub
End If
End If
ThisDrawing.Regen acAllViewports
UserForm1.Show

End Sub

Bạn chỉ giúp minh với, mình mò mà không được, phần PL nó không add dc text bạn ah.

Cảm ơn 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

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
×