Đến nội dung


Hình ảnh
- - - - -

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


  • Please log in to reply
32 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 27 November 2013 - 11:24 AM

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

  • 0

#2 thikb219

thikb219

    biết zoom

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

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

Không ai giúp mình với à híc

 


  • 0

#3 gia_bach

gia_bach

    biết lệnh adcenter

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

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

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)

  • 1

#4 thikb219

thikb219

    biết zoom

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

Đã gửi 27 November 2013 - 03:54 PM

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!


  • 0

#5 gia_bach

gia_bach

    biết lệnh adcenter

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

Đã gửi 28 November 2013 - 12:44 PM

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

  • 1

#6 thikb219

thikb219

    biết zoom

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

Đã gửi 28 November 2013 - 01:35 PM

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


  • 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 28 November 2013 - 01:49 PM

Gửi bạn nè: 

 

http://www.cadviet.c...575_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

  • 1

Thanks and Best Regards

Skype : dinhvantrang73


#8 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 28 November 2013 - 02:03 PM

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


  • 1

Thanks and Best Regards

Skype : dinhvantrang73


#9 thikb219

thikb219

    biết zoom

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

Đã gửi 28 November 2013 - 04:40 PM

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


  • 0

#10 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 - 07:17 AM

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


  • 1

Thanks and Best Regards

Skype : dinhvantrang73


#11 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:09 AM

ok thank bạn  và thank mọi người trên diễn dàn rất nhiều rất nhiều mình đã làm được  :P  


  • 0

#12 phuong44e1

phuong44e1

    Edu level: li4

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

Đã gửi 15 March 2016 - 10:58 AM

 

Gửi bạn nè: 

 

http://www.cadviet.c...575_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.


  • 0

#13 phuong44e1

phuong44e1

    Edu level: li4

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

Đã gửi 15 March 2016 - 12:13 PM

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?


  • 0

#14 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 15 March 2016 - 11:21 PM

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 à


  • 1

Thanks and Best Regards

Skype : dinhvantrang73


#15 phuong44e1

phuong44e1

    Edu level: li4

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

Đã gửi 17 March 2016 - 08:29 AM

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.


  • 0

#16 phuong44e1

phuong44e1

    Edu level: li4

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

Đã gửi 17 March 2016 - 08:43 AM

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


  • 0

#17 ndtnv

ndtnv

    biết lệnh minsert

  • Members
  • PipPipPipPipPipPip
  • 437 Bài viết
Điểm đánh giá: 384 (khá)

Đã gửi 17 March 2016 - 08:45 AM

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


  • 0

#18 phuong44e1

phuong44e1

    Edu level: li4

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

Đã gửi 17 March 2016 - 10:24 AM

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


  • 0

#19 gia_bach

gia_bach

    biết lệnh adcenter

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

Đã gửi 17 March 2016 - 11:05 AM

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

  • 1

#20 phuong44e1

phuong44e1

    Edu level: li4

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

Đã gửi 17 March 2016 - 11:10 AM

 

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


  • 0