EXCEL与CAD相互转换

lcydpwch

请问各位高手有没有关于EXCEL与CAD相互转换的扩展,或小程序?
请给本人一个:邮箱:427707146@qq.com

qiang

Dim xcelapp As New Excel.Application

'由EXCEL文件生成CAD表格
Sub excelread()
xcelapp.Workbooks.Open "d:\\book3.xls", , ReadOnly
Dim i As Integer
Dim j As Integer
i = 2
j = 65
With xcelapp.ActiveWorkbook.Worksheets("报价")
'获得行数
Do
If .Range("a" & i) = "" Then
Exit Do
End If
i = i + 1
Loop
'获得列数
Do
If .Range(Chr(j) & "1") = "" Then
Exit Do
End If
j = j + 1
Loop
End With
Call drawtable(i, j)
xcelapp.Workbooks.Close
xcelapp.Quit
End Sub

Private Sub drawtable(ByVal x As Integer, ByVal y As Integer)
Dim newl As AcadLine '绘制直线
Dim startp(2) As Double '定义直线起点
Dim endp(2) As Double '定义直线终点

Dim i As Integer '循环变量
Dim newtext1 As AcadMText
'定义直线起点
startp(0) = 0
startp(1) = 0
startp(2) = 0
'定义直线终点
endp(0) = 60 * (y - 65)
endp(1) = 0
endp(2) = 0
'画横线
Do While i < x + 2
Set newl = ThisDrawing.ModelSpace.AddLine(startp, endp)
startp(1) = startp(1) + 10
endp(1) = endp(1) + 10
i = i + 1
Loop
'画竖线，定义起始点
endp(0) = 0
endp(1) = 10 * (x + 1)
startp(1) = 0
startp(0) = 0
For i = 1 To y - 64
'画第一条竖线，并写入第一列文本
Set newl = ThisDrawing.ModelSpace.AddLine(startp, endp)
Call addtext(endp(0), x, i)
startp(0) = startp(0) + 60
endp(0) = endp(0) + 60
Next
ThisDrawing.Application.Update
End Sub

Private Sub addtext(ByVal x As Double, ByVal rs As Integer, ByVal cs As Integer)
Dim newtext As AcadMText '写入文本
Dim insertp(2) As Double '定义文本的插入点
Dim i As Integer
Dim j As Integer
j = 64 + cs
'获得文本的插入点
insertp(0) = x + 2
insertp(1) = (rs + 2) * 10 - 12.5
insertp(2) = 0
i = 1
Do While i < rs
Set newtext = ThisDrawing.ModelSpace.AddMText(insertp, 50, xcelapp.ActiveWorkbook.Worksheets("报价").Range(Chr(j) & i))
newtext.Height = 5
i = i + 1
insertp(1) = insertp(1) - 10
Loop
End Sub

'由CAD表格转为EXCEL表格

Sub getdata()
Dim sel As AcadSelectionSet
Dim i As Integer
Dim j As Integer
Dim start1 As Variant
Dim end1 As Variant
Dim str(300, 300) As String
Dim newline As AcadLine
Dim newmtext As AcadMText
Dim rows As Integer
Dim cols As Integer
Dim rowlen As Double
Dim collen As Double
On Error Resume Next
'选择对象
Set sel = ThisDrawing.SelectionSets.Add("ssel")
If Err Then
Err.Clear
Set sel = ThisDrawing.SelectionSets.Item("ssel")
End If
On Error GoTo 0
sel.SelectOnScreen
Dim Ent As AcadEntity
'计算行数及列数
For Each Ent In sel
If LCase(Ent.ObjectName) = "acdbline" Then
Set newline = Ent
start1 = newline.StartPoint
end1 = newline.EndPoint
If start1(0) = end1(0) Then
j = j + 1
collen = newline.Length
ElseIf start1(1) = end1(1) Then
i = i + 1
rowlen = newline.Length
End If
End If
Next
For Each Ent In sel
'将文本写入数组
If LCase(Ent.ObjectName) = "acdbmtext" Then
Set newmtext = Ent
start1 = newmtext.InsertionPoint
cols = start1(0) \\ rowlen / (j - 1)
rows = i - start1(1) \\ collen / (i - 1) - 2
str(rows, cols) = newmtext.TextString
End If
Next
Call writeexcel(str, i, j)
sel.Delete
End Sub

Private Sub writeexcel(ByVal p As Variant, ByVal x As Integer, ByVal y As Integer)
Dim i As Integer
Dim j As Integer
Dim excelapp As New Excel.Application
Dim excelwkbk As Excel.Workbook
Set excelwkbk = excelapp.Workbooks.Add
MsgBox excelwkbk.Name

With excelwkbk.Worksheets("sheet1")
For i = 1 To x
For j = 65 To y + 65
.Range(Chr(j) & i) = p(i - 1, j - 65)
Next
Next
End With
excelapp.ActiveWorkbook.SaveAs "d:\\hxj.xls"
excelapp.Workbooks.Close
excelapp.Quit
End Sub

qiang

一个小程序