论坛首页    职业区    学术与写作    工程技术区    软件区    资料区    商务合作区    社区办公室
 您好! 欢迎 登录注册 最新帖子 邀请注册 活动聚焦 统计排行 社区服务 帮助
 
  • 帖子
  • 日志
  • 用户
  • 版块
  • 群组
帖子
  • 4257阅读
  • 13回复

求大神帮忙用VBA编程画这几个图,急急急,先谢谢啦!!!!!!! [复制链接]

上一主题 下一主题
离线q616019
 

发帖
3
土币
40
威望
1
原创币
0
只看楼主 倒序阅读 使用道具 楼主  发表于: 2013-04-15
关键词: VBA画图




离线yjy4519

发帖
149
土币
9
威望
0
原创币
0
只看该作者 1楼 发表于: 2013-04-15
第一幅图的程序写好了,给你贴上去;
Sub huitu1()
Dim cir As AcadCircle
Dim cent1(0 To 2) As Double  ' 小圆圆心
Dim rr As Double '半径
Dim linep1(0 To 2) As Double '线条端点1
Dim linep2(0 To 2) As Double '线条端点1
Dim centerp As Variant '中心坐标
Dim retObj As Variant
Dim numberOfRows As Long
Dim numberOfColumns As Long
Dim numberOfLevels As Long
Dim distanceBwtnRows As Double
Dim distanceBwtnColumns As Double
Dim distanceBwtnLevels As Double
On Error Resume Next
kuan = ThisDrawing.Utility.GetReal("矩形宽度:")
chang = ThisDrawing.Utility.GetReal("矩形长度:")
rr = ThisDrawing.Utility.GetReal("请输入小圆半径:")
centerp = ThisDrawing.Utility.GetPoint(, "定位绘图中心:")
'绘制矩形
linep1(0) = centerp(0) + chang / 2
linep1(1) = centerp(1) + kuan / 2
linep2(0) = centerp(0) - chang / 2
linep2(1) = centerp(1) - kuan / 2
Call drawbox(linep1, linep2) '调用画矩形子程序
'绘小圆
cent1(0) = centerp(0) - 25
cent1(1) = centerp(1) - 16
Set cir = ThisDrawing.ModelSpace.AddCircle(cent1, rr)
numberOfRows = 2
numberOfColumns = 2
numberOfLevels = 1
distanceBwtnRows = 32
distanceBwtnColumns = 50
distanceBwtnLevels = 1
retObj = cir.ArrayRectangular(numberOfRows, numberOfColumns, numberOfLevels, distanceBwtnRows, distanceBwtnColumns, distanceBwtnLevels)
ZoomAll
End Sub
Private Sub drawbox(p1, p2) '根据对角线坐标画矩形的子程序
Dim boxp(0 To 14) As Double
boxp(0) = p1(0)
boxp(1) = p1(1)
boxp(3) = p1(0)
boxp(4) = p2(1)
boxp(6) = p2(0)
boxp(7) = p2(1)
boxp(9) = p2(0)
boxp(10) = p1(1)
boxp(12) = p1(0)
boxp(13) = p1(1)
Call ThisDrawing.ModelSpace.AddPolyline(boxp)
End Sub
1条评分土币+1
q616019 土币 +1 感谢解答,给您加分 2013-04-16
离线edelmann

发帖
2975
土币
53408
威望
7629
原创币
0
只看该作者 2楼 发表于: 2013-04-16
1楼的真行。
好人!
离线yjy4519

发帖
149
土币
9
威望
0
原创币
0
只看该作者 3楼 发表于: 2013-04-16
第二张图的程序:
Sub zhenlie()
Dim rr1 As Double '半径
Dim rr2 As Double
Dim rr3 As Double
Dim centerp As Variant '中心坐标
Dim zly As AcadCircle
On Error Resume Next
centerp = ThisDrawing.Utility.GetPoint(, "定位绘图中心:")
rr1 = ThisDrawing.Utility.GetReal("请输入内圆的半径:")
rr2 = ThisDrawing.Utility.GetReal("请输入外圆的半径:")
rr3 = ThisDrawing.Utility.GetReal("请输入阵列圆的半径:")
'绘小圆
Call Example_AddCircle(centerp, rr1) '调用画圆子程序
Call Example_AddCircle(centerp, rr2)
Set zly = ThisDrawing.ModelSpace.AddCircle(centerp, rr3)
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
Dim point3(0 To 2) As Double
Dim point4(0 To 2) As Double
Dim point5(0 To 2) As Double
Dim point6(0 To 2) As Double
point1(0) = centerp(0): point1(1) = centerp(1)
point2(0) = centerp(0) - (rr1 + rr2) / 2: point2(1) = centerp(1)
zly.Move point1, point2
zly.Update
point3(0) = centerp(0): point3(1) = centerp(1) + rr2 + 10
point4(0) = centerp(0): point4(1) = centerp(1) - rr2 - 10
point5(0) = centerp(0) - rr2 - 10: point5(1) = centerp(1)
point6(0) = centerp(0) + rr2 + 10: point6(1) = centerp(1)
Call ThisDrawing.ModelSpace.AddLine(point3, point4) '竖直中心线
Call ThisDrawing.ModelSpace.AddLine(point5, point6) '水平中心线
Dim noOfObjects As Integer
Dim angleToFill As Double
Dim basePnt(0 To 2) As Double
Dim retObj As Variant
noOfObjects = 8
angleToFill = 3.1415926 * 2        ' 360 degrees
basePnt(0) = centerp(0): basePnt(1) = centerp(1)
retObj = zly.ArrayPolar(noOfObjects, angleToFill, basePnt)
ZoomAll
End Sub
Private Sub Example_AddCircle(c0, rr) '根据圆心和半径绘制圆的子程序
Dim centerPoint As Variant
Dim radius As Double
'定义圆
centerPoint = c0
radius = rr
'在模型空间中创建圆对象
Call ThisDrawing.ModelSpace.AddCircle(centerPoint, radius)
End Sub
离线q616019

发帖
3
土币
40
威望
1
原创币
0
只看该作者 4楼 发表于: 2013-04-16
感谢解答,给您加分
离线liuufan0616

发帖
33
土币
48
威望
1
原创币
0
只看该作者 5楼 发表于: 2013-04-22
高手啊  ,遇到这样的高手真是压力很大啊
离线yjy4519

发帖
149
土币
9
威望
0
原创币
0
只看该作者 6楼 发表于: 2013-04-22
第三幅图的,矩形的相对位置关系略有问题,你可以自己调一下
Option Explicit

Public Sub huitu3()
    ' 该示例在模型空间中创建圆弧。
  
    Dim arcObj1 As AcadArc
    Dim arcObj2 As AcadArc
    Dim centerPoint1(0 To 2) As Double
    Dim centerPoint2(0 To 2) As Double
    Dim radius1 As Double
    Dim radius2 As Double
    Dim startAngleInDegree1 As Double
    Dim startAngleInDegree2 As Double
    Dim endAngleInDegree1 As Double
    Dim endAngleInDegree2 As Double
    
    ' 定义圆
    centerPoint1(0) = 0#: centerPoint1(1) = 0#: centerPoint1(2) = 0#
    centerPoint2(0) = -95#: centerPoint2(1) = 65#: centerPoint2(2) = 0#
    radius1 = 5#
    radius2 = 60#
    startAngleInDegree1 = 0#
    endAngleInDegree1 = 90#
    startAngleInDegree2 = 0#
    endAngleInDegree2 = 90#
    ' 转换度数表示的角度为弧度表示的角度
    Dim startAngleInRadian1 As Double
    Dim startAngleInRadian2 As Double
    Dim endAngleInRadian1 As Double
    Dim endAngleInRadian2 As Double
    startAngleInRadian1 = startAngleInDegree1 * 3.1415926 / 180#
    endAngleInRadian1 = endAngleInDegree1 * 3.1415926 / 180#
    startAngleInRadian2 = startAngleInDegree2 * 3.1415926 / 180#
    endAngleInRadian2 = endAngleInDegree2 * 3.1415926 / 180#
    ' 在模型空间中创建圆弧对象
    Set arcObj1 = ThisDrawing.ModelSpace.AddArc(centerPoint1, radius1, startAngleInRadian1, endAngleInRadian1)
    Set arcObj2 = ThisDrawing.ModelSpace.AddArc(centerPoint2, radius2, startAngleInRadian2, endAngleInRadian2)
    ' 开始倒圆角
    Dim myr As Double
    myr = 30
    ThisDrawing.SendCommand "_fillet" & vbCr & "r" & vbCr & myr & vbCr
    ThisDrawing.SendCommand "_fillet" & vbCr & "0,5,0" & vbCr & "-35,65,0" & vbCr
    Dim p1(0 To 2) As Double
    Dim p2(0 To 2) As Double
    Dim p3(0 To 2) As Double
    Dim line1 As AcadLine
    Dim line2 As AcadLine
    p1(0) = 5: p1(1) = 0: p1(2) = 0
    p2(0) = 5: p2(1) = -40: p2(2) = 0
    p3(0) = -95: p3(1) = -40: p3(2) = 0
    Set line1 = ThisDrawing.ModelSpace.AddLine(p1, p2)
    Set line2 = ThisDrawing.ModelSpace.AddLine(p2, p3)
    '镜像所绘制图形
    '镜像轴线
    Dim p4(0 To 2) As Double
    Dim p5(0 To 2) As Double
    Dim ent As AcadEntity
    p4(0) = -95: p4(1) = 135: p4(2) = 0
    p5(0) = -95: p5(1) = -50: p5(2) = 0
    For Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
    ent.Mirror p4, p5 '镜像
    Next ent
    '绘制小圆
    Dim circle1 As AcadCircle
    Dim radius3 As Double
    radius3 = 30
    '绘制小矩形
    Dim p6(0 To 2) As Double
    Dim p7(0 To 2) As Double
    p6(0) = -125: p6(1) = -20: p6(2) = 0
    p7(0) = -65: p7(1) = 0: p7(2) = 0
    Call drawbox(p6, p7)
    Set circle1 = ThisDrawing.ModelSpace.AddCircle(centerPoint2, radius3)
    ZoomAll
End Sub
Private Sub drawbox(p1, p2) '根据对角线坐标画矩形的子程序
Dim boxp(0 To 14) As Double
boxp(0) = p1(0)
boxp(1) = p1(1)
boxp(3) = p1(0)
boxp(4) = p2(1)
boxp(6) = p2(0)
boxp(7) = p2(1)
boxp(9) = p2(0)
boxp(10) = p1(1)
boxp(12) = p1(0)
boxp(13) = p1(1)
Call ThisDrawing.ModelSpace.AddPolyline(boxp)
End Sub
离线yjy4519

发帖
149
土币
9
威望
0
原创币
0
只看该作者 7楼 发表于: 2013-04-22
我写的程序比较繁琐,你可以优化一下
离线q616019

发帖
3
土币
40
威望
1
原创币
0
只看该作者 8楼 发表于: 2013-04-24
谢谢大神啊 您真是帮了大忙了
离线caogis

发帖
235
土币
41
威望
550
原创币
0
只看该作者 9楼 发表于: 2013-07-03
yjy4519 是真大神呀!
离线gh000054

发帖
39
土币
37
威望
1
原创币
0
只看该作者 10楼 发表于: 2014-06-02
果真是牛B大神,膜拜
离线zhaishoujun

发帖
360
土币
2034
威望
413
原创币
0
只看该作者 11楼 发表于: 2014-10-25
是真大神呀!
快速回复
限100 字节
温馨提示:欢迎交流讨论,请勿纯表情、纯引用!
 
上一个 下一个

      https://beian.mps.gov.cn/ 粤公网安备 44010602012919号 广州半山岩土网络科技有限公司 粤ICP备2024274469号

      工业和信息化部备案管理系统网站