根据excel表格数据绘制图形

平凡的夏夜清风 · 发表于 2015-1-25 15:05

这个有些行业非常实用！

鱼与熊掌 · 发表于 2015-1-25 18:53

，我就看看不说话

zjsru_18_505 · 发表于 2015-1-27 19:10

本帖最后由 zjsru_18_505 于 2015-1-27 19:13 编辑

看图中数据，图形是平行四边形。
试试这个，打开后，运行里面的宏。

http://bbs.mjtd.com/forum.php?mod=attachment&aid=ODY4NDR8NGNiYTFiMzUxNjQ5NDYxOWQ3YjE3ODY3OTM4NDIwYzd8MTcxNDExNjgxNg%3D%3D&request=yes&_f=.rar

平凡的夏夜清风 · 发表于 2015-1-27 19:58

zjsru_18_505 发表于 2015-1-27 19:10
看图中数据，图形是平行四边形。
试试这个，打开后，运行里面的宏。

怎么画出来的图是竖向排列，并且没有标注啊？

zjsru_18_505 · 发表于 2015-1-28 12:23

Dim AutoCADObj As Object
Dim ActivedocumentObj As Object
Dim ModelspaceObj As Object
Dim LineObj As Object
Dim TextStyle As Object, TextString As Object
Dim LayerObj As Object
Dim start As Variant '曲线起始点
Dim P0 As Variant
Dim StartPoint(0 To 2) As Double '直线的起点
Dim EndPoint(0 To 2) As Double '直线的终点
Dim POINT As Integer
Dim i As Integer
Dim DimObj As Object
Private Sub UserForm_Initialize()
On Error GoTo errtext
With Worksheets(1)
i = 1
Do While Trim(.Cells(i, 1)) <> ""
i = i + 1
Loop
POINT = i - 1 '总的点数
End With
Exit Sub
errtext:
TextBox1.Text = "error"
End Sub
Private Sub CommandButton1_Click()
On Error GoTo obj
Set AutoCADObj = CreateObject("AutoCAD.Application") '创建CAD对象
Set ActivedocumentObj = AutoCADObj.ActiveDocument '创建绘图对象
Set ModelspaceObj = ActivedocumentObj.ModelSpace '创建绘图空间对象
''''''''''''''添加图层''''''''''''''''''''''''''''''''''''
Set LayerObj = ActivedocumentObj.Layers.Add("temp")
'LayerObj.Color = 2
''''''''''''''''添加文字样式''''''''''''''''''''''''''''''''''''''''
Set TextStyle = ActivedocumentObj.TextStyles.Add("st") '添加新的文件样式st
TextStyle.SetFont "宋体", False, False, 1, 1 '指定样式st的字体为宋体
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
AutoCADObj.Application.Visible = True '使AutoCAD窗口显示
Dim A As Single
Dim B As Single
Dim C As Single
Dim D As Single
Dim ACR As Single
With Worksheets(1)
start = ActivedocumentObj.Utility.GetPoint(, "指定左下角：")
For i = 2 To POINT
A = .Cells(i, 7)
B = .Cells(i, 5)
C = .Cells(i, 2)
EndPoint(0) = start(0)
EndPoint(1) = start(1)
EndPoint(2) = start(2)
StartPoint(0) = start(0) + C
StartPoint(1) = start(1)
StartPoint(2) = start(2)
Call Line
ACR = Application.WorksheetFunction.Acos((B * B + C * C - A * A) / (2 * A * B))
P0 = ActivedocumentObj.Utility.PolarPoint(start, ACR, B)
StartPoint(0) = EndPoint(0)
StartPoint(1) = EndPoint(1)
StartPoint(2) = EndPoint(2)
EndPoint(0) = P0(0)
EndPoint(1) = P0(1)
EndPoint(2) = P0(2)
Call Line
P0 = ActivedocumentObj.Utility.PolarPoint(P0, 0, C)
StartPoint(0) = EndPoint(0)
StartPoint(1) = EndPoint(1)
StartPoint(2) = EndPoint(2)
EndPoint(0) = P0(0)
EndPoint(1) = P0(1)
EndPoint(2) = P0(2)
Call Line
StartPoint(0) = EndPoint(0)
StartPoint(1) = EndPoint(1)
StartPoint(2) = EndPoint(2)
EndPoint(0) = start(0) + C
EndPoint(1) = start(1)
EndPoint(2) = start(2)
Call Line
StartPoint(0) = start(0) + C / 2
StartPoint(1) = start(1)
StartPoint(2) = start(2)
start(0) = start(0) + C + B
start(1) = start(1)
start(2) = start(2)
Set TextString = ModelspaceObj.AddText(.Cells(i, 1), StartPoint, CSng(TextBox1.Text) + 7.6)
TextString.styleName = "st" '指定样式名
TextString.layer = "temp"
TextString.Alignment = 9 '左中对齐
TextString.Rotation = 3.14 / 2 '旋转角度90度
TextString.Textalignmentpoint = StartPoint '重定义对齐点
'TextString.Update '更新显示
Next
AutoCADObj.zoomall
End With
'obj.Update '刷新对象,使其更新
'CADo.Quit '退出对象
Set AutoCADObj = Nothing
Set ActivedocumentObj = Nothing
Set ModelspaceObj = Nothing
Set LineObj = Nothing
Set LayerObj = Nothing
Set TextString = Nothing
Set DimObj = Nothing
End
Exit Sub
'Set obj = Nothing
obj:
MsgBox "对象已被清除或数据格式不对!", , "错误"
End Sub
Sub Line()
Dim x As Single, y As Single, DI As Single
Dim P1 As Variant
x = StartPoint(0) - EndPoint(0)
y = StartPoint(1) - EndPoint(1)
DI = Sqr(x * x + y * y) / 2
Set LineObj = ModelspaceObj.AddLine(StartPoint, EndPoint)
LineObj.layer = "temp"
'LineObj.Update
P1 = ActivedocumentObj.Utility.PolarPoint(StartPoint, ActivedocumentObj.Utility.AngleFromXAxis(StartPoint, EndPoint), DI)
P1 = ActivedocumentObj.Utility.PolarPoint(P1, ActivedocumentObj.Utility.AngleFromXAxis _
(StartPoint, EndPoint) + WorksheetFunction.Pi / 2, CSng(TextBox1.Text))
A = ActivedocumentObj.Utility.AngleFromXAxis(StartPoint, EndPoint)
Set DimObj = ModelspaceObj.AddDimAligned(StartPoint, EndPoint, P1)
DimObj.TextHeight = CSng(TextBox1.Text) / 2
DimObj.SuppressTrailingZeros = False
End Sub

Dim AutoCADObj As Object 
Dim ActivedocumentObj As Object 
Dim ModelspaceObj As Object 
Dim LineObj As Object 
Dim TextStyle As Object, TextString As Object 
Dim LayerObj As Object 
Dim start As Variant              '曲线起始点 
Dim P0 As Variant 
Dim StartPoint(0 To 2) As Double  '直线的起点 
Dim EndPoint(0 To 2) As Double    '直线的终点 
Dim POINT As Integer 
Dim i As Integer 
Dim DimObj As Object 
 
 
 
 
Private Sub UserForm_Initialize() 
 
On Error GoTo errtext 
 
With Worksheets(1) 
 
i = 1 
Do While Trim(.Cells(i, 1)) <> "" 
i = i + 1 
Loop 
 
POINT = i - 1                     '总的点数 
 
 
 
 
End With 
Exit Sub 
 
errtext: 
TextBox1.Text = "error" 
End Sub 
 
 
 
Private Sub CommandButton1_Click() 
 
 
On Error GoTo obj 
 
Set AutoCADObj = CreateObject("AutoCAD.Application")    '创建CAD对象 
Set ActivedocumentObj = AutoCADObj.ActiveDocument         '创建绘图对象 
Set ModelspaceObj = ActivedocumentObj.ModelSpace          '创建绘图空间对象 
 
''''''''''''''添加图层'''''''''''''''''''''''''''''''''''' 
Set LayerObj = ActivedocumentObj.Layers.Add("temp") 
    'LayerObj.Color = 2 
    
''''''''''''''''添加文字样式'''''''''''''''''''''''''''''''''''''''' 
Set TextStyle = ActivedocumentObj.TextStyles.Add("st")    '添加新的文件样式st 
TextStyle.SetFont "宋体", False, False, 1, 1           '指定样式st的字体为宋体 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
 
 
AutoCADObj.Application.Visible = True                     '使AutoCAD窗口显示 
 
Dim A As Single 
Dim B As Single 
Dim C As Single 
Dim D As Single 
Dim ACR As Single 
 
With Worksheets(1) 
 
 
start = ActivedocumentObj.Utility.GetPoint(, "指定左下角：") 
 
 
For i = 2 To POINT 
 
 
    A = .Cells(i, 7) 
    B = .Cells(i, 5) 
    C = .Cells(i, 2) 
 
 
 
    EndPoint(0) = start(0) 
    EndPoint(1) = start(1) 
    EndPoint(2) = start(2) 
    StartPoint(0) = start(0) + C 
    StartPoint(1) = start(1) 
    StartPoint(2) = start(2) 
    Call Line 
    
    ACR = Application.WorksheetFunction.Acos((B * B + C * C - A * A) / (2 * A * B)) 
    P0 = ActivedocumentObj.Utility.PolarPoint(start, ACR, B) 
    StartPoint(0) = EndPoint(0) 
    StartPoint(1) = EndPoint(1) 
    StartPoint(2) = EndPoint(2) 
    EndPoint(0) = P0(0) 
    EndPoint(1) = P0(1) 
    EndPoint(2) = P0(2) 
    Call Line 
    
    P0 = ActivedocumentObj.Utility.PolarPoint(P0, 0, C) 
    StartPoint(0) = EndPoint(0) 
    StartPoint(1) = EndPoint(1) 
    StartPoint(2) = EndPoint(2) 
    EndPoint(0) = P0(0) 
    EndPoint(1) = P0(1) 
    EndPoint(2) = P0(2) 
    Call Line 
             
    StartPoint(0) = EndPoint(0) 
    StartPoint(1) = EndPoint(1) 
    StartPoint(2) = EndPoint(2) 
    EndPoint(0) = start(0) + C 
    EndPoint(1) = start(1) 
    EndPoint(2) = start(2) 
    Call Line 
    
    StartPoint(0) = start(0) + C / 2 
    StartPoint(1) = start(1) 
    StartPoint(2) = start(2) 
    
    start(0) = start(0) + C + B 
    start(1) = start(1) 
    start(2) = start(2) 
 
    
    
    Set TextString = ModelspaceObj.AddText(.Cells(i, 1), StartPoint, CSng(TextBox1.Text) + 7.6) 
    TextString.styleName = "st"                    '指定样式名 
    TextString.layer = "temp" 
    TextString.Alignment = 9                         '左中对齐 
    TextString.Rotation = 3.14 / 2                   '旋转角度90度 
    TextString.Textalignmentpoint = StartPoint        '重定义对齐点 
    'TextString.Update                                '更新显示 
 
Next 
 
AutoCADObj.zoomall 
 
End With 
 
'obj.Update                                          '刷新对象,使其更新 
'CADo.Quit                                           '退出对象 
Set AutoCADObj = Nothing 
Set ActivedocumentObj = Nothing 
Set ModelspaceObj = Nothing 
Set LineObj = Nothing 
Set LayerObj = Nothing 
Set TextString = Nothing 
Set DimObj = Nothing 
End 
Exit Sub 
'Set obj = Nothing 
obj: 
MsgBox "对象已被清除或数据格式不对!", , "错误" 
 
End Sub 
 
 
 
Sub Line() 
Dim x As Single, y As Single, DI As Single 
Dim P1 As Variant 
 
x = StartPoint(0) - EndPoint(0) 
y = StartPoint(1) - EndPoint(1) 
DI = Sqr(x * x + y * y) / 2 
 
Set LineObj = ModelspaceObj.AddLine(StartPoint, EndPoint) 
LineObj.layer = "temp" 
'LineObj.Update 
 
P1 = ActivedocumentObj.Utility.PolarPoint(StartPoint, ActivedocumentObj.Utility.AngleFromXAxis(StartPoint, EndPoint), DI) 
P1 = ActivedocumentObj.Utility.PolarPoint(P1, ActivedocumentObj.Utility.AngleFromXAxis _ 
     (StartPoint, EndPoint) + WorksheetFunction.Pi / 2, CSng(TextBox1.Text)) 
A = ActivedocumentObj.Utility.AngleFromXAxis(StartPoint, EndPoint) 
 
Set DimObj = ModelspaceObj.AddDimAligned(StartPoint, EndPoint, P1) 
DimObj.TextHeight = CSng(TextBox1.Text) / 2 
DimObj.SuppressTrailingZeros = False 
       
End Sub

平凡的夏夜清风 · 发表于 2015-1-29 19:56

zjsru_18_505 发表于 2015-1-28 12:23

这次基本可以了，就是编号是竖向的，简单修改了下，可以了，学习了！！

平凡的夏夜清风 · 发表于 2015-1-30 08:44

zjsru_18_505 发表于 2015-1-28 12:23

再请教下，图绘制出来后，对角线误差很大，是怎么回事？

zjsru_18_505 · 发表于 2015-1-30 14:01

平凡的夏夜清风发表于 2015-1-30 08:44
再请教下，图绘制出来后，对角线误差很大，是怎么回事？

有一句写错了。

ACR = Application.WorksheetFunction.Acos((B * B + C * C - A * A) / (2 * A * B))

改为

ACR = Application.WorksheetFunction.Acos((B * B + C * C - A * A) / (2 * C * B))

vink8023 · 发表于 2021-6-22 20:44

可以添加个联系方式吗：我QQ：1079118454，需要找你定制插件

账号		自动登录	找回密码
密码			注册

[提问] 根据excel表格数据绘制图形

本帖子中包含更多资源