第1页 / 共12页
第2页 / 共12页
第3页 / 共12页
第4页 / 共12页
第5页 / 共12页
第6页 / 共12页
第7页 / 共12页
第8页 / 共12页
将EXCEL表格导入CAD中的VBA源代码.pdf
将 EXCEL 表格导入 CAD 中程序
VBA 中窗体
CAD 中运行
找到要输入表
按制表,根据提示结果为:
源代码如下:
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook '工作薄
Dim xlSheet As Excel.Worksheet '工作表
Dim TA(51, 8) As String '文字
Dim MC(51, 8) As Boolean '合并
Dim MA(51, 8) As String '合并范围
Dim MB(51, 8) As Long '合并范围长度
Dim Hal(51, 8) As Byte '完成设置范围
Dim ia, jb As Byte '表范围
Dim TATab(8), Bl As Byte '列字数宽
Dim Mtab As Integer '最大表宽
Dim BiH, ZiLa, Bmin As Single '字高比,字栏比,最小表宽
Dim myFilename As String '文件名
Dim CW(51, 8) As Long '对齐方式
Dim Dhx(820) As Double '横线 x
Dim Dhy(820) As Double '横线 y
Dim Dhse(820) As Byte ''横线点类型
Dim DhNo, DsNo, TxNo As Long
Dim Dsx(820) As Double ' '竖线 x
Dim Dsy(820) As Double '竖线 y
Dim Dsse(820) As Byte ''竖线点类型
Dim p5(1), p6(1) As Double
Dim Si, Sj As Long
Private Sub CommandButton1_Click()
'用户输入值,及字高比,字栏比的允许范围
If TextBox2.Text < 0.3 Then TextBox2.Text = 0.3
If TextBox2.Text > 1 Then TextBox2.Text = 1
If TextBox1.Text < 0.3 Then TextBox1.Text = 0.3
If TextBox1.Text > 1.5 Then TextBox1.Text = 1.5
BiH = TextBox1.Text
ZiLa = TextBox2.Text
On Error GoTo Rnext: '出错陷井
'在程序中操作 EXCEL 表常用命令:######################################
Set xlApp = CreateObject("Excel.Application") '创建 EXCEL 对象
If myFilename = "" Then
sh = MsgBox("查找表格文件", 0)
GoTo Rnext:
End If
Me.Hide ' 隐藏表
Set xlBook = xlApp.Workbooks.Open(myFilename) '打开已经存在的 EXCEL 工件簿文件
xlApp.Visible = False '设置 EXCEL 对象可见（或不可见）
Set xlSheet = xlBook.Worksheets(1) '设置活动工作表
'取表的单元格数据
For j = 1 To 8
For i = 1 To 50
TA(i, j) = xlSheet.Cells(i, j)
MC(i, j) = xlSheet.Cells(i, j).MergeCells
MA(i, j) = xlSheet.Cells(i, j).MergeArea.Address
CW(i, j) = xlSheet.Cells(i, j).HorizontalAlignment
If TA(i, j) <> "" Then '取表有效行列数
If ia < i Then
ia = i
End If
If jb < j Then
jb = j
End If
End If '取表有效行列数
Bl = LenB(StrConv(TA(i, j), vbFromUnicode)) '取单元格列宽(2 字节)
If Bl > TATab(j) And MC(i, j) = False Then TATab(j) = Bl + 1 '非合并的单元格列
Next i
Next j
Mtab = 0
For j = 1 To jb
Mtab = TATab(j) + Mtab '计算表总字宽
Next j
'Exl 结束#############################################
xlBook.Close (True) '关闭工作簿
xlApp.Quit '结束 EXCEL 对象
Set xlApp = Nothing '释放 xlApp 对象
'表建图层#############################################
Dim lay0 As AcadLayer '定义作为图层的变量
Dim lay1 As AcadLayer
findlay = 0 ' 寻找图层的结果的变量，0 没有找到，1 找到
For Each lay0 In ThisDrawing.Layers ' 在所有的图层中进行循环
If lay0.Name = "chable" Then ' 如果找到图层名
findlay = 1 ' 把变量改为 1 标志着图层已经找到
If Not lay0.LayerOn Then lay0.LayerOn = True '打开`
ThisDrawing.ActiveLayer = lay0 ' 把当前图层设为已经存在的图层##########
End If
Exit For ' 结束寻找
'End If
Next lay0
If findlay = 0 Then '没有找到图层########
Set lay1 = ThisDrawing.Layers.Add("chable") ' 增加一个名为"临时图层"的图层
lay1.color = 4 ' 图层设置为青色
ThisDrawing.ActiveLayer = lay1 ' 将当前图层设置为新建图层
End If
'画表格######################################
Dim p1 As Variant '申明端点坐标.
Dim p2 As Variant
Dim pt As Variant '临时点
Dim p0(2) As Double
Dim p3(2) As Double
Dim p4(2) As Double
Dim H0, B0 As Double '行总高,列总宽
Dim Hi, Bj As Double '行高,列宽
Dim D1 As Variant '申明端点坐标.
Dim D2 As Variant
Dim Lx(9) As Double '表络线坐标
Dim LxT As Double
Dim Ly(52) As Double '表格坐标
'获取表格位置和大小
p1 = ThisDrawing.Utility.GetPoint(, "表格起点 P1:") '获取点坐标
z = 0
p1(2) = 0 '将 Z 坐标值赋予点坐标中
p2 = ThisDrawing.Utility.GetPoint(, "表格对角点 P2:") '获取点坐标
p2(2) = 0
'左上为起点,右下角为终点
If p1(0) > p2(0) Then '左右调换
pt = p1
p1 = p2
p2 = pt
End If
If p1(1) < p2(1) Then '上下调换
pt = p1
pt(1) = p2(1)
p2(1) = p1(1)
p1 = pt
End If
H0 = p1(1) - p2(1) '表高
B0 = p2(0) - p1(0) '表宽
Hi = H0 / ia '行高
LxT = p1(0)
Ly(0) = p1(1)
For i = 0 To ia
Ly(i) = Ly(0) - Hi * i
Next
Bmin = 0.95 * Hi * Mtab * ZiLa * BiH * 0.5 '按排字,最小表宽
If B0 <= Bmin Then '输入范围是否满足
p2(0) = p1(0) + Bmin
B0 = Bmin '不够,就按排字最小表宽
End If
Bj = B0 / Mtab '每英文字的宽度
For j = 0 To jb
Lx(j) = LxT + Bj * TATab(j)
LxT = Lx(j)
Next
'画表外框线
s1 = p1(0)
p3(0) = Val(s1)
s2 = p2(1)
p3(1) = Val(s2)
p3(2) = 0
Call ThisDrawing.ModelSpace.AddLine(p1, p3) ' 画直线
Call ThisDrawing.ModelSpace.AddLine(p3, p2) ' 画直线
p3(0) = p2(0)
p3(1) = p1(1)
Call ThisDrawing.ModelSpace.AddLine(p2, p3) ' 画直线
Call ThisDrawing.ModelSpace.AddLine(p3, p1) ' 画直线
'画表外框线
'计算线坐标
'Dim Tx(410) As Double '文字 x
'Dim Yy(410) As Double '文字 y
Dim Ttmp, A1, B1, C1 As String '转换临时
Dim i1, Lm As Byte '转换临时
Dim A1i, A1j, A2i, A2j As Byte '合并单元格范围
Dim Hai, Haj, imB As Byte '合并单元格范围
DhNo = 0
DsNo = 0
TxNo = 0
For i = 1 To ia
For j = 1 To jb
'TA(i, j) = xlSheet.Cells(i, j)
If Hal(i, j) <> 1 Then '已计算'完成设置范围
If MC(i, j) = True Then ' xlSheet.Cells(i, j).MergeCells
'分离合并单元格数据
Ttmp = MA(i, j)
i1 = InStr(Ttmp, ":")
A1 = Left(Ttmp, i1 - 1)
Lm = Len(Ttmp)
B1 = Right(Ttmp, Lm - i1)
Lm = Len(A1)
A1 = Right(A1, Lm - 1)
Lm = Len(B1)
B1 = Right(B1, Lm - 1)
i1 = InStr(A1, "$")
C1 = Left(A1, i1 - 1)
A1j = Val(AZ1(C1))
Lm = Len(A1)
A1i = Val(Right(A1, Lm - i1))
i1 = InStr(B1, "$")
C1 = Left(B1, i1 - 1)
A2j = Val(AZ1(C1))
Lm = Len(B1)
A2i = Val(Right(B1, Lm - i1))
'转横线坐标
Dhx(DhNo) = Lx(A1j - 1)
Dhy(DhNo) = Ly(A2i)
Dhse(DhNo) = 1
DhNo = DhNo + 1
Dhx(DhNo) = Lx(A2j)
Dhy(DhNo) = Ly(A2i)
Dhse(DhNo) = 2
DhNo = DhNo + 1
For Hai = A1i To A2i
For Haj = A1j To A2j
Hal(Hai, Haj) = 1 '完成设置范围
Next Haj
Next Hai
For imB = A1j To A2j
MB(i, j) = MB(i, j) + TATab(imB) '合并单元格长度
Next imB
'转竖线坐标
Dsx(DsNo) = Lx(A2j)
Dsy(DsNo) = Ly(A1i - 1)
Dsse(DsNo) = 1
DsNo = DsNo + 1
Dsx(DsNo) = Lx(A2j)
Dsy(DsNo) = Ly(A2i)
Dsse(DsNo) = 2
DsNo = DsNo + 1
Else
Ttmp = MA(i, j)
'转横线坐标
Dhx(DhNo) = Lx(j - 1)
Dhy(DhNo) = Ly(i)
Dhse(DhNo) = 1
DhNo = DhNo + 1
Dhx(DhNo) = Lx(j)
Dhy(DhNo) = Ly(i)
Dhse(DhNo) = 2
DhNo = DhNo + 1
'转竖线坐标
Dsx(DsNo) = Lx(j)
Dsy(DsNo) = Ly(i - 1)
Dsse(DsNo) = 1
DsNo = DsNo + 1
Dsx(DsNo) = Lx(j)
Dsy(DsNo) = Ly(i)
Dsse(DsNo) = 2
DsNo = DsNo + 1
End If
End If
Next j
Next i
p3(2) = 0
p4(2) = 0
i = 1
For j = 0 To DhNo
If Dhse(j) = 1 Then
p3(0) = Dhx(j)
p3(1) = Dhy(j)
i = i + 1
End If
If Dhse(j) = 2 Then
p4(0) = Dhx(j)
p4(1) = Dhy(j)
i = i + 1
End If
'画横线
If i = 3 Then
i = 1
Call ThisDrawing.ModelSpace.AddLine(p3, p4) '画直线
End If
Next j
'画竖线
i = 1
相关推荐
2023年江西萍乡中考道德与法治真题及答案.doc
2012年重庆南川中考生物真题及答案.doc
2013年江西师范大学地理学综合及文艺理论基础考研真题.doc
2020年四川甘孜小升初语文真题及答案I卷.doc
2020年注册岩土工程师专业基础考试真题及答案.doc
2023-2024学年福建省厦门市九年级上学期数学月考试题及答案.doc
2021-2022学年辽宁省沈阳市大东区九年级上学期语文期末试题及答案.doc
2022-2023学年北京东城区初三第一学期物理期末试卷及答案.doc
2018上半年江西教师资格初中地理学科知识与教学能力真题及答案.doc
2012年河北国家公务员申论考试真题及答案-省级.doc
2020-2021学年江苏省扬州市江都区邵樊片九年级上学期数学第一次质量检测试题及答案.doc
2022下半年黑龙江教师资格证中学综合素质真题及答案.doc
