TheSwamp
Code Red => VB(A) => Topic started by: Humbertogo on May 30, 2007, 07:51:20 AM
-
Help :lol:
How can i addMtext in the midpoint of a rectangle and the same angle of the rectangle?
-
Can you get the two coordinates from the rectangle's bounding box, and then calculate the midpoint? I can't help you with VBA, but I just did almost the same coding task in Vlisp the other day.
-
Help :lol:
How can i addMtext in the midpoint of a rectangle and the same angle of the rectangle?
Is the angle 3D or 2D?
-
the angle is 2D
-
Describe the rectangle. Is it allways the same size etc.
-
Here's a little snippet from one of my programs. It uses regular text though. It allows the user to select two points to create the rectangle and automatically adds the text at the center of the rectangle.
Option Explicit
Public Sub DrawTextInRectangle()
Dim pnt1 As Variant, pnt2 As Variant
Dim ctr(0 To 2) As Double, ht As Double
Dim newText As AcadText
Dim strText As String
Dim intTextHeight As Integer
strText = "THIS SPACE FOR RENT"
intTextHeight = 10
If getPoints1(pnt1, pnt2) = 0 Then
Rectangle pnt1, pnt2
' Now add text at the midpoint of the rectangle...
ctr(0) = (pnt1(0) + pnt2(0)) / 2
ctr(1) = (pnt1(1) + pnt2(1)) / 2
ctr(2) = (pnt1(2) + pnt2(2)) / 2
ht = Abs(pnt1(1) - pnt2(1)) / 2
Set newText = ThisDrawing.ModelSpace.AddText(UCase(strText), ctr, intTextHeight)
newText.Alignment = 4
newText.TextAlignmentPoint = ctr
newText.StyleName = "Standard"
newText.Update
End If
End Sub
' From Frank Oquendo
Private Function Rectangle(Point1, Point2) As AcadLWPolyline
Dim vertices(0 To 7) As Double, pl As AcadLWPolyline
vertices(0) = CDbl(Point1(0)): vertices(1) = CDbl(Point1(1))
vertices(2) = CDbl(Point2(0)): vertices(3) = CDbl(Point1(1))
vertices(4) = CDbl(Point2(0)): vertices(5) = CDbl(Point2(1))
vertices(6) = CDbl(Point1(0)): vertices(7) = CDbl(Point2(1))
Set pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(vertices)
pl.Closed = True
Set Rectangle = pl
End Function
Private Function getPoints1(pt1 As Variant, pt2 As Variant) As Integer
' This sub returns two points, or an error flag if cancelled
On Error Resume Next
pt1 = ThisDrawing.Utility.GetPoint(, "Specify first corner:")
If Err Then
getPoints1 = -1
Exit Function
End If
pt2 = ThisDrawing.Utility.GetCorner(pt1, "Specify opposite corner:")
If Err Then
getPoints1 = -1
Exit Function
End If
On Error GoTo 0
End Function
-
(http://)
-
attach
-
That's, ummmm..... not a rectangle. Close, but it's not a rectangle.
Sounds/looks like you need to find the centroid of a closed polyline instead??
-
That can be an easy one to do, and will help everyone, if you try to code something first, what is the code you have done, so far?
Thanks.
-
in my drawing i have a different rectangles
i get some point and create a close polyline
Dim LastObj As AcadEntity
Dim objLWPolyline(0) As AcadLWPolyline
Dim minExt As Variant
Dim maxExt As Variant
Dim MTextObj As AcadMText
Dim corner(0 To 2) As Double
Dim Pt As Variant, _
varArea As String, _
pstr As String, _
SysVarName As String, _
sysVarName2 As String, _
VarData As Variant, _
intData As Double, _
textObj As AcadText, _
text As Variant, _
Height As Variant, _
Msg As String, _
varMinPt As Variant, _
varMaxPt As Variant
Private Sub test()
SysVarName = "DIMSCALE"
sysVarName2 = "AREA"
With ThisDrawing
.SetVariable "OSMODE", 0
.SetVariable "CMDECHO", 0
'' Multiple getpoint method by Tony Tanzillo
Msg = vbCrLf & "Select an Internal Point"
Do
On Error Resume Next
Pt = .Utility.GetPoint(, Msg)
If Err Then
Err.Clear
Exit Do
End If
On Error GoTo 0
pstr = Replace(CStr(Pt(0)), ",", ".") & "," & _
Replace(CStr(Pt(1)), ",", ".")
.SendCommand Chr(3) & Chr(3) & "._-boundary" & vbCr & pstr & vbCr & vbCr
Set LastObj = .ModelSpace.Item(.ModelSpace.Count - 1)
If TypeOf LastObj Is AcadLWPolyline Then
Set objLWPolyline(0) = LastObj
objLWPolyline(0).GetBoundingBox varMinPt, varMaxPt
objLWPolyline(0).Delete
End If
corner(0) = varMinPt(0): corner(1) = varMaxPt(1): corner(2) = 0#
Height = 2000#
Set MTextObj = .ModelSpace.AddMText(corner, 10, "50")
MTextObj.Height = Height
' MTextObj.Rotate MTextObj.insertionPoint, lineObj.Angle
' MTextObj.Move MTextObj.insertionPoint, lineObj.endPoint
' Set textObj = .ModelSpace.AddText(varArea, Pt, Height)
' textObj.Update
Msg = vbCrLf & "Next Internal Point or ENTER to exit: "
Loop
On Error GoTo 0
.SetVariable "OSMODE", 703
.SetVariable "CMDECHO", 1
End With
MsgBox "Done"
End Sub
-
I see why, I never went all the way with VBA, it is ugly the coding there... :)
Here is something I just did in C#, very simple, that might help you, you simple select a rectangle area, and the routine will place a text inside. HTH
using System;
using Autodesk.AutoCAD.Runtime;
using System.Collections.Generic;
using System.ComponentModel;
using System.Data;
using System.Text;
using System.IO;
using Autodesk.AutoCAD.ApplicationServices;
using Autodesk.AutoCAD.DatabaseServices;
using Autodesk.AutoCAD.Windows;
using Autodesk.AutoCAD.Geometry;
using Autodesk.AutoCAD.EditorInput;
using System.Text.RegularExpressions;
using System.Runtime.InteropServices;
using System.Threading;
using System.Globalization;
using acadApp = Autodesk.AutoCAD.ApplicationServices.Application;
using AcAp = Autodesk.AutoCAD.ApplicationServices;
using AcEd = Autodesk.AutoCAD.EditorInput;
using AcGe = Autodesk.AutoCAD.Geometry;
using AcRx = Autodesk.AutoCAD.Runtime;
using AcDb = Autodesk.AutoCAD.DatabaseServices;
using AcWd = Autodesk.AutoCAD.Windows;
Auxiliary functions:
public static double Angle(Point3d pt1, Point3d pt2)
{
return Math.Atan2((pt2.Y - pt1.Y), (pt2.X - pt1.X));
}
public static Point3d Polar(Point3d ptBase, double angle, double distance)
{
return new Point3d(ptBase.X + (distance * Math.Cos(angle)), ptBase.Y + (distance * Math.Sin(angle)), 0.0);
}
public static double Distance(Point3d pt1, Point3d pt2)
{
return Math.Sqrt(Math.Pow(pt2.X - pt1.X, 2) + Math.Pow(pt2.Y - pt1.Y, 2));
}
Command:
[CommandMethod("PLACETEXT")]//place some text inside a rectangle area
public void placetext()
{
Document doc = acadApp.DocumentManager.MdiActiveDocument;
Editor ed = doc.Editor;
Database db = doc.Database;
PromptEntityResult res = ed.GetEntity("\nSelect the rectangle base line: ");
if (res.Status != PromptStatus.OK) return;
using (Transaction tr = db.TransactionManager.StartTransaction())
{
Polyline poly = tr.GetObject(res.ObjectId, OpenMode.ForRead, false) as Polyline;
if (poly != null)
{
Point3d pickPoint = res.PickedPoint;
Point3d oPoint = poly.GetClosestPointTo(pickPoint, ed.GetCurrentView().ViewDirection, false);
double param = 0;
param = poly.GetParameterAtPoint(oPoint);
double sparam=0, eparam=0;
sparam = (int)param;
eparam = sparam + 1;
Point3d sp = poly.GetPointAtParameter(sparam);
Point3d ep = poly.GetPointAtParameter(eparam);
double ang = Angle(sp, ep);
Extents3d ext = poly.GeometricExtents;
Point3d min = ext.MinPoint;
Point3d max = ext.MaxPoint;
Point3d geoCtr = Polar(min, Angle(min, max), Distance(min, max) / 2.0);
BlockTableRecord btr = (BlockTableRecord)tr.GetObject(db.CurrentSpaceId, OpenMode.ForWrite);
DBText txt = new DBText();
txt.TextString = "TESTING"; //<==change to your default string value
txt.SetDatabaseDefaults(db);
txt.Height = Distance(min, max) / 8.0; //<==change to your default height
txt.HorizontalMode = TextHorizontalMode.TextMid;
txt.Rotation = ang;
btr.AppendEntity(txt);
tr.AddNewlyCreatedDBObject(txt, true);
txt.AlignmentPoint = geoCtr;
}
tr.Commit();
}
}
-
There is not exactly what you
need but may help I think
You can add there the part to get
second point on the desired edge and then
calculate rotation angle of text
~'J'~
Option Explicit
Sub AddSomeLabel()
Dim varPt As Variant
Dim oPoly As AcadLWPolyline
Dim oEnt As AcadEntity
With ThisDrawing
.Utility.GetEntity oEnt, varPt, "Select polyline (pick left point on the edge)"
If TypeOf oEnt Is AcadLWPolyline Then
Set oPoly = oEnt
Else
MsgBox "Wrong entity selected"
Exit Sub
End If
Dim txtPt As Variant
txtPt = PseudoCenter(oPoly)
Dim oText As AcadMText
Dim txtStr As String
txtStr = "Blah\PBlah\PBlah"
Dim pointUCS As Variant
pointUCS = .Utility.TranslateCoordinates(txtPt, acUCS, acUCS, False)
Set oText = MakeMText(pointUCS, txtStr)
End With
End Sub
Function MakeMText(txtPt As Variant, strTxt As String) As AcadMText
Dim oMText As AcadMText
Dim oLine As AcadLine
Set oMText = ThisDrawing.ModelSpace.AddMText(txtPt, 0#, strTxt)
oMText.AttachmentPoint = acAttachmentPointMiddleCenter
oMText.InsertionPoint = txtPt
oMText.Update
Set MakeMText = oMText
End Function
Function PseudoCenter(oPoly As AcadLWPolyline) As Variant
Dim minPt As Variant
Dim maxPt As Variant
oPoly.GetBoundingBox minPt, maxPt
Dim centPt(2) As Double
centPt(0) = (minPt(0) + maxPt(0)) / 2
centPt(1) = (minPt(1) + maxPt(1)) / 2
centPt(2) = (minPt(2) + maxPt(2)) / 2
PseudoCenter = centPt
End Function
-
Mathimatically this is very problematic.
The first instinct is to use the centroid as Matt suggested,
however this fails with an "L" as the centroid is outside the line,
Luis's method will always work (if I can read it correctly)
-
Sorry I do not have time to code it, but this is what I would do:
I would make a region from the polyline. If the polyline is not closed I would set the system variable of plinetype to 2. Then sendcommand pedit, maybe using the multiple option. Then turn the close polyline into a region and get the centroid. As long as these so called rectangles are close enough to one, the centroid should be fine.
Next I would find the longest line in that rectangle and get its start and endpoint. Get its angle from the wcs, either by drawing a line or parsing the polyline for the longest line and their length. Then use the returned centroid and the angle of the line/points to place the text.
-
Mathimatically this is very problematic.
The first instinct is to use the centroid as Matt suggested,
however this fails with an "L" as the centroid is outside the line,
Luis's method will always work (if I can read it correctly)
Thanks Bryco I knew that by OP
asked about contours similar on
rectangles though...
Regards
~'J'~
-
Mathimatically this is very problematic.
The first instinct is to use the centroid as Matt suggested,
however this fails with an "L" as the centroid is outside the line,
Luis's method will always work (if I can read it correctly)
Bryco;
I did not look at that, but to fix it in a simple way is to just add the code below to my function:
Point3d p1 = poly.GetPointAtParameter(0.0);
Line line1 = new Line(p1, geoCtr);
Point3dCollection points = new Point3dCollection();
poly.IntersectWith(line1, Intersect.OnBothOperands, points, 0, 0);
if (points.Count == 2)
{
txt.AlignmentPoint = Polar(points[0], Angle(points[0], points[1]), Distance(points[0], points[1]) / 2.0);
}
The above, will force the position of the text to be inside of the area, if it is an L or U shape, is not optimized but (can be) works!
And the whole function modified/updated:
[CommandMethod("PLACETEXT")]//place some text inside a rectangle area
public void placetext()
{
Document doc = acadApp.DocumentManager.MdiActiveDocument;
Editor ed = doc.Editor;
Database db = doc.Database;
PromptEntityResult res = ed.GetEntity("\nSelect the rectangle base line: ");
if (res.Status != PromptStatus.OK) return;
using (Transaction tr = db.TransactionManager.StartTransaction())
{
Polyline poly = tr.GetObject(res.ObjectId, OpenMode.ForRead, false) as Polyline;
if (poly != null)
{
Point3d pickPoint = res.PickedPoint;
Point3d oPoint = poly.GetClosestPointTo(pickPoint, ed.GetCurrentView().ViewDirection, false);
double param = 0;
param = poly.GetParameterAtPoint(oPoint);
double sparam=0, eparam=0;
sparam = (int)param;
eparam = sparam + 1;
Point3d sp = poly.GetPointAtParameter(sparam);
Point3d ep = poly.GetPointAtParameter(eparam);
double ang = Angle(sp, ep);
Extents3d ext = poly.GeometricExtents;
Point3d min = ext.MinPoint;
Point3d max = ext.MaxPoint;
Point3d geoCtr = Polar(min, Angle(min, max), Distance(min, max) / 2.0);
BlockTableRecord btr = (BlockTableRecord)tr.GetObject(db.CurrentSpaceId, OpenMode.ForWrite);
DBText txt = new DBText();
txt.TextString = "TESTING";
txt.SetDatabaseDefaults(db);
txt.Height = Distance(min, max) / 8.0;
txt.HorizontalMode = TextHorizontalMode.TextMid;
txt.Rotation = ang;
btr.AppendEntity(txt);
tr.AddNewlyCreatedDBObject(txt, true);
txt.AlignmentPoint = geoCtr;
Point3d p1 = poly.GetPointAtParameter(0.0);
Line line1 = new Line(p1, geoCtr);
Point3dCollection points = new Point3dCollection();
poly.IntersectWith(line1, Intersect.OnBothOperands, points, 0, 0);
if (points.Count == 2)
{
txt.AlignmentPoint = Polar(points[0], Angle(points[0], points[1]), Distance(points[0], points[1]) / 2.0);
}
}
tr.Commit();
}
}
-
I'll try that tonight Luis.
Fatty you are right.
-
I will try in C#
one more question how can i translatethis code in C#
:-D
.SendCommand Chr(3) & Chr(3) & "._-boundary" & vbCr & pstr & vbCr & vbCr
Set LastObj = .ModelSpace.Item(.ModelSpace.Count - 1)
If TypeOf LastObj Is AcadLWPolyline Then
Set objLWPolyline(0) = LastObj
objLWPolyline(0).GetBoundingBox varMinPt, varMaxPt
objLWPolyline(0).Delete
End If
-
I will try in C#
one more question how can i translatethis code in C#
:-D
.SendCommand Chr(3) & Chr(3) & "._-boundary" & vbCr & pstr & vbCr & vbCr
Set LastObj = .ModelSpace.Item(.ModelSpace.Count - 1)
If TypeOf LastObj Is AcadLWPolyline Then
Set objLWPolyline(0) = LastObj
objLWPolyline(0).GetBoundingBox varMinPt, varMaxPt
objLWPolyline(0).Delete
End If
:-o want to use sendcommand?... I would rather go and draw the polyline without using the command boundary... but is up to you.
If I have time, I will try to write something, so you pick the points of an area, then create a closed polyline, and want to place any text inside no? or is that text the area?... just want to confirm....
Thanks.
-
LE,
In my drawing i have a routing of house, my idea was to pick
a point in mid. of each house create a closed polyline and place text inside
-
I see, ... but you have here something to start (did you tested the command PLACETEXT or adapted the C# code to suit your needs?), the only other problem I see, is that when you end up having an area, where the command boundary or bpoly, not capable to generate the closed area, then you will require to do it manually or make your own boundary generator, when bpoly fails, will see if a solution is provided...
[edited by me]
-
Oh y that is the one :-D
-
I solved your problem in VBA by not using Mtext but linear Dimensions. First, I determined the midpoint XYs of the two opposite vertical(ish) rectangle sides for positioning and aligning the dimension. Then, I set the dimension offset to 0, turned all dimension graphics off (arrows etc.) and replaced the dimension value with the text I desired.
-
I'm trying to do something along those same lines- :lol:
I'm working at using a Region to obtain the Room Length x Width for a Room Size attribute.
Anyone else already done this...?
-
may no the best way but i solved the problem in VBA :-D
Public Sub test()
Dim intnum As Integer
Dim PolyCoord As Variant
Dim PolySp(0 To 2) As Double
Dim PolyEp(0 To 2) As Double
Dim AngleInDegree As Double
Dim strAng As String
intnum = 5
NumCout = 2
With ThisDrawing
.SetVariable "OSMODE", 0
.SetVariable "CMDECHO", 0
Msg = vbCrLf & "Select an Internal Point"
Do
On Error Resume Next
Pt = .Utility.GetPoint(, Msg)
If Err Then
Err.Clear
Exit Do
End If
On Error GoTo 0
pstr = Replace(CStr(Pt(0)), ",", ".") & "," & _
Replace(CStr(Pt(1)), ",", ".")
.SendCommand Chr(3) & Chr(3) & "._-boundary" & vbCr & pstr & vbCr & vbCr
Set LastObj = .ModelSpace.Item(.ModelSpace.Count - 1)
If TypeOf LastObj Is AcadLWPolyline Then
Set objLWPolyline(0) = LastObj
objLWPolyline(0).GetBoundingBox varMinPt, varMaxPt
' Return all the coordinates of the polyline
PolyCoord = objLWPolyline(0).Coordinates
PolySp(0) = PolyCoord(0): PolySp(1) = PolyCoord(1)
PolyEp(0) = PolyCoord(2): PolyEp(1) = PolyCoord(3)
objLWPolyline(0).Delete
Set objLine = ThisDrawing.ModelSpace.AddLine(PolySp, PolyEp)
AngleInDegree = Format(objLine.Angle / PI * 180# + 90 - 270, "##.000")
objLine.Delete
strAng = Replace(CStr(AngleInDegree), ",", ".")
dblAngle = .Utility.AngleToReal(strAng, acDegrees)
End If
corner(0) = varMinPt(0): corner(1) = varMaxPt(1): corner(2) = 0#
Height = 2000#
midPoint(0) = (varMinPt(0) + varMaxPt(0)) / 2
midPoint(1) = (varMinPt(1) + varMaxPt(1)) / 2
midPoint(2) = 0
Set MTextObj = .ModelSpace.AddMText(corner, 10, " {\fVerdana|b0|i0|c0|p34;" & intnum & "}")
MTextObj.Height = Height
MTextObj.AttachmentPoint = acAttachmentPointMiddleCenter
Call MTextObj.Rotate(midPoint, dblAngle)
MTextObj.Move MTextObj.insertionPoint, midPoint
MTextObj.color = acYellow
intnum = intnum + NumCout
Msg = vbCrLf & "Next Internal Point or ENTER to exit: "
Loop
On Error GoTo 0
.SetVariable "OSMODE", 703
.SetVariable "CMDECHO", 1
End With
MsgBox "Done"
End Sub
-
Humbertogo,
Why not create the MText first, then just use BoundingBox to create a rectangle around it?
-
the bounding box doesn't detect the text but the grip box of an mtext object.... this can be smaler or biger then the contained text.
-
right
-
He wants to place a text in the geometric center or inside of a boundary (Lot), normally will be a rectangle, that's what I understood :).
-
in the center of a boundary