如何用vba创建一个矩形?

shicai

懸懸懸

哈哈  楼主加油

mccad

'通过对角两点绘制矩形的函数
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

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

zhuqi75

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

efan2000

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

兰州人

ntyks发表于2009-8-29 15:09:00呵呵，提个复杂点的：用矩形中心线上的两点呢？两点是矩形中心线与两边的交点，矩形的宽度为输入的数值。

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

cjb2187

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

写得不是太严谨,只是说明这样的程序是可以完成的,应该还有更好的办法,大家再琢磨吧

cjb2187

我觉得还有一个办法,但是没有试验过,思路如下:

1)新建一个坐标系,要求所点的两个点Y值相同(相对于世界坐标旋转一个角度)

2)获得第三个点,坐标是第一个点Y值减2.5

3)获得第四个点,坐标是第二个点Y值加2.5

4)按此两点画一个矩形(这应该不难)

5)把坐标转回来,仍使用世界坐标