社区 › 数据库/EXCEL/objectDBX/RealDWG 编程技术 › 我写的EXCEL与CAD互相转换表格的程序。

XJ_HE 发表于 2003-12-1 13:07:00

我写的EXCEL与CAD互相转换表格的程序。

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

XJ_HE 发表于 2003-12-1 13:11:00

主要是针对联通设计院的模板生成表格，所以有点数据上面，主要是针对我的工作
还请LEE版主及各位多提意见

leeyeafu 发表于 2003-12-2 11:37:00

一点点小建议

要对已经运行正确的程序说三道四不是件容易的事，也是件不容易受欢迎的事。既然楼点名，不说几句总是不对的。
以下说的都仅仅是程序的一点点小问题，只要在平时编程注意一下就可以了。
1、标志符命名时最好用大小写混写，例如：定义时用DrawTable，以后编程时倒是可以写成drawtable，这样当写完一行时，VBA IDE就会立即将其改成DrawTable，这样可以立即检查是否出现拼写错误。
2、在drawtable子程序中并没有使用那个AcadMText对象，从而不需要Dim它。当然，我知道你开始是准备使用它，程序定型后忘记删除这个Dim了。
3、实际上，Dim那个AcadLine也没有必要，绘图时直接用以下代码：
ThisDrawing.ModelSpace.AddLine startp, endp
就可以了。当然，如果在程序中要查询或者编辑它就另当别论了。
同样，在addtext子程序中的AcadMText也可以不要声明，这样可以稍稍提高代码效率。
4、在getdata子程序中，str变量声明为300*300的String数组，使用程序失去了灵活性，也降低了代码效率，可以这样修改：
先声明str为Variant变量：   Dim str As Variant
在获取行数和列数后重新声明：ReDim str(0 To i, 0 To j) As String
5、将整个str数组作为参数传递给writeexcel子程序，若使用ByVal方法，你的目的是保证在子程序中该数组内容的修改不会影响到子程序以外，但运行时需要在内存中复制整个数组，当数组较大时，这样效率会大大降低，你楼主仔细斟酌是否有这个必要。由于程序在调用writeexcel以后并没有再使用str数组，因此，我建议这个参数不要用ByVal传递。

XJ_HE 发表于 2003-12-3 08:59:00

感谢LEE版主，我没有什么经验。主要是在学习了您写的那个读写EXCEL文件后，
针对自己的需要写的小东东。
这次又得到您这么多帮助。就此贡献鲜花 一朵。呵呵：）THANKS

yswu 发表于 2004-3-3 09:52:00

请教


我在调试上面的代码时        For        Each        Ent        In        sel提示类型不匹配


应如何修改


谢谢<BR>

leeyeafu 发表于 2004-3-3 11:32:00

To 5楼：


你是否忘记了Dim Ent As AcadEntity?


如果方便，请帖出你的部分代码。


楼主的代码和我写《VBA读写EXCEL数据的一般方法》中的代码都已经运行通过，不会出现你说的错误。

yswu 发表于 2004-3-4 08:52:00

你好


我就是把搂主的'由CAD表格转为EXCEL表格代码照搬过去的


是不是要在运行过程中要引用一些特殊的库文件什么的


我是个新手对VBA不了解


只是想实现把CAD里的材料表转到EXCEL里


谢谢

leeyeafu 发表于 2004-3-4 09:01:00

ACAD VBA中：“工具”菜单-&gt;“引用”，选择“Microsoft Excel 9.0 Object Library”，当然，根据你机器中的EXCEL应用程序版本不同，可能不是9.0。

gamelemon 发表于 2004-4-1 14:44:00

我在读取excel表中的坐标到CAD中并连成线的程序，不知有没有人编写出来呢

mikewolf2k 发表于 2004-4-11 19:45:00

gamelemon发表于2004-4-1 14:44:00static/image/common/back.gif我在读取excel表中的坐标到CAD中并连成线的程序，不知有没有人编写出来呢

<BR>这个更简单了,都无需编程,以前有这方面的例子,你找找看

查看完整版本: 我写的EXCEL与CAD互相转换表格的程序。