如何用vba创建一个矩形?

懸懸懸 · 发表于 2021-2-11 17:26:00

哈哈楼主加油

mccad · 发表于 2002-11-28 21:29:00

'通过对角两点绘制矩形的函数
Function AddRectangle(varPnt1 As Variant, varPnt2 As Variant) As AcadLWPolyline
  On Error GoTo Err_Control

  Dim objSpace As AcadBlock
If ThisDrawing.ActiveSpace = acModelSpace Then
   Set objSpace = ThisDrawing.ModelSpace
Else
   Set objSpace = ThisDrawing.PaperSpace
End If

Dim plineObj As AcadLWPolyline
Dim points(0 To 7) As Double

points(0) = varPnt1(0): points(1) = varPnt1(1)
points(2) = varPnt1(0): points(3) = varPnt2(1)
points(4) = varPnt2(0): points(5) = varPnt2(1)
points(6) = varPnt2(0): points(7) = varPnt1(1)

Set plineObj = objSpace.AddLightWeightPolyline(points)
   plineObj.Closed = True
Set AddRectangle = plineObj

Exit_Here:
  Exit Function

Err_Control:
  Resume Exit_Here
End Function
Sub addrec()
  Dim pnt1 As Variant
  Dim pnt2 As Variant
  pnt1 = ThisDrawing.Utility.GetPoint(, "请输入角点：")
  pnt2 = ThisDrawing.Utility.GetCorner(pnt1, "请输入另一角点：")
  AddRectangle pnt1, pnt2

End Sub

shicai · 发表于 2002-12-3 05:46:00

看来VBA没有像Lisp中Rectangle那样的功能, 如不常用, 没必要编程, 用addline罢了.

zhuqi75 · 发表于 2003-1-23 13:24:00

你这人真是的，人家好心给你程序，你却。。。。

efan2000 · 发表于 2003-1-23 19:57:00

你不是要用VB创建矩形吗，既然自己不编写，而又不需要别人的，那你到底想怎么做？

ntyks · 发表于 2009-8-29 15:09:00

请将需求,用数学表达式表示出来。

兰州人 · 发表于 2009-8-29 17:37:00

Sub addrec()
Dim pt(1 To 2) As Variant
Dim pt1(14) As Double
Dim Recobj As AcadPolyline
Dim l, s, XDiffer, YDiffer, sca As Double
l = 5
pt(1) = ThisDrawing.Utility.GetPoint(, "请输入矩形第一条宽边的中心点")
pt(2) = ThisDrawing.Utility.GetPoint(, "请输入矩形第二条宽边的中心点")
XDiffer = pt(2)(0) - pt(1)(0)
YDiffer = pt(2)(1) - pt(1)(1)
s = (XDiffer ^ 2 + YDiffer ^ 2) ^ (1 / 2)
sca = l / 2 / s
pt1(0) = pt(1)(0) - YDiffer * sca
pt1(1) = pt(1)(1) + XDiffer * sca
pt1(2) = 0#
pt1(3) = pt(1)(0) + YDiffer * sca
pt1(4) = pt(1)(1) - XDiffer * sca
pt1(5) = 0#
pt1(6) = pt(2)(0) + YDiffer * sca
pt1(7) = pt(2)(1) - XDiffer * sca
pt1(8) = 0#
pt1(9) = pt(2)(0) - YDiffer * sca
pt1(10) = pt(2)(1) + XDiffer * sca
pt1(11) = 0#
pt1(12) = pt1(0)
pt1(13) = pt1(1)
pt1(14) = pt1(2)
Set Recobj = ThisDrawing.ModelSpace.AddPolyline(pt1)
Recobj.Update
End Sub
写得不是太严谨,只是说明这样的程序是可以完成的,应该还有更好的办法,大家再琢磨吧

ntyks · 发表于 2009-9-29 14:41:00

我觉得还有一个办法,但是没有试验过,思路如下:
1)新建一个坐标系,要求所点的两个点Y值相同(相对于世界坐标旋转一个角度)
2)获得第三个点,坐标是第一个点Y值减2.5
3)获得第四个点,坐标是第二个点Y值加2.5
4)按此两点画一个矩形(这应该不难)
5)把坐标转回来,仍使用世界坐标

如何用vba创建一个矩形?

发表回复

精选推荐