[VBA程序]：利用VBA编程实现从EXCEL表到AUTOCAD表转换

zhqchn · 发表于 2003-9-3 20:13:54

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

' ExcelToCad
'
'**********************************************************************
'原作:
' 计算机世界报　　新疆交通科学研究所　查拥军
' "利用VBA编程实现从EXCEL表到AUTOCAD表转换"
'**********************************************************************
'改编:
' zhqchn
'**********************************************************************
'简介:
' 如何将Excel的制表计算与AutoCad的绘图功能结合，是很多人关心的问题
' Atable的出现以及unionsoft的TrueTable的迅速成熟为大家解决了大问题
' 本人曾动过开发类似软件的念头，但接触TrueTable后就觉得没有必要了。
' 前段时间看到有网友将查拥军的这篇文章贴到论坛，引来了不少关注，
' 说明还是有不少人不满足于现成的工具，希望搞清原理，而查先生的程序
' 只是摘录，也可能是故意隐去一些东西，因此不能直接运行，我将此程序
' 做了修正，并加了一些注释,使有兴趣的初学者更容易调试，便于学习。
' 我只是在原程序的基础是修正一些错误，程序还有很多不完善的地方，
' 水平有限，高手莫笑话。
' 程序请从cmdTableToExcel_Click运行，hxw中的Call wz(c, strText)
' 是控制文字样式的，若打开，程序运行会很慢。
'***********************************************************************
'
Option Explicit
Private Sub cmdTableToExcel_Click()
Call ConnectCAD
Call ConnectEXCEL
Call tableToExcel
End Sub
Sub tableToExcel()
Call hxw
End Sub
'---- 在AutoCAD中，线条有多种，考虑能够方便控制线条属性，选用了多义线。具体命令如下： RetVal =object.AddLightWeightPolyline (VerticesList)
'---- 下面的程序演示表格线条读取和画表格线的具体过程。
Sub hxw()
Dim a As Integer '表格的最大行数
Dim b As Integer '表格的最大列数
Dim xinit As Double '插入点x坐标
Dim yinit As Double '插入点y坐标
Dim zinit As Double '插入点z坐标
Dim xinsert As Double '当前单元格的左上角点的x左标
Dim yinsert As Double '当前单元格的左上角点的y左标
Dim ptarray(0 To 3) As Double '画表格线(lwpolyline)的顶点坐标
Dim X As Integer '循环变量(表格行)
Dim Y As Integer '循环变量(表格列)
Dim c As Object '单元格地址
Dim ma As Object '合并单元格
Dim xl As Variant
Dim xh As Integer '单元格宽
Dim yh As Integer '单元格高
Dim xlRange As Object
Dim xpoint As Double '当前单元格的左上角点的x左标(已加上插入点x坐标)
Dim ypoint As Double '当前单元格的左上角点的y左标(已加上插入点y坐标)
Dim lwployobj As AcadLWPolyline '多义线
Dim textobj As AcadMText '文本
Dim fptText(0 To 2) As Double '文本插入点
Dim strText As String '文本内容
Dim txtHeight As Double '文本高度
a = xlApp.Selection.Rows.Count
b = xlApp.Selection.Columns.Count
For X = 1 To a
For Y = 1 To b
Set c = xlSht.Range(zh(Y) + Trim(str(X)))
'以行号、列号获得单元格地址
Set ma = c.MergeArea
'求出单元格C的合并单元格地址
Dim tempStr As String
tempStr = Trim(ma.Address)
If ma.Count > 1 Then tempStr = Divide(Trim(ma.Address), ":", 0)
If tempStr = Trim(c.Address) Then
'假如c.mergearea的绝对地址 , 如果前4个字符与c单元格的地址相同
xl = "A1:" + ma.Address
xh = xlSht.Range(ma.Address).Width
yh = xlSht.Range(ma.Address).Height
Set xlRange = xlSht.Range(xl)
xinsert = xlRange.Width - xh
yinsert = xlRange.Height - yh
xpoint = xinit + xinsert
ypoint = yinit - yinsert
If X = 1 Then '第一行
If ma.Borders(xlEdgeTop).LineStyle <> xlNone Then
ptarray(0) = xpoint
'第一点坐标（数组下标 0 and 1)
ptarray(1) = ypoint
ptarray(2) = xpoint + xh
'第二点坐标（数组下标 2 and 3)
ptarray(3) = ypoint
Set lwployobj = moSpace.AddLightWeightPolyline(ptarray)
'在AutoCAD文件里画线
With lwployobj
'.Layer = newlayer.Name '指定lwployobj所在图层
.Color = acBlue '指定lwployobj的颜色
End With
Lineweight lwployobj, ma.Borders(xlEdgeTop).Weight
lwployobj.Update
End If
End If
If ma.Borders(xlEdgeBottom).LineStyle <> xlNone Then
ptarray(0) = xpoint + xh
'第三点坐标（数组下标 0 and 1)
ptarray(1) = ypoint - yh
ptarray(2) = xpoint
'第四点坐标（数组下标 2 and 3）
ptarray(3) = ypoint - yh
Set lwployobj = moSpace.AddLightWeightPolyline(ptarray)
'在AutoCAD文件里画线
With lwployobj
'.Layer = newlayer.Name '指定lwployobj所在图层
.Color = acBlue '指定lwployobj的颜色
End With
Lineweight lwployobj, ma.Borders(xlEdgeBottom).Weight
lwployobj.Update
End If
If Y = 1 Then '第一列
If ma.Borders(xlEdgeLeft).LineStyle <> xlNone Then
ptarray(0) = xpoint
'第四点坐标（数组下标 0 and 1)
ptarray(1) = ypoint - yh
ptarray(2) = xpoint
'第一点坐标（数组下标 2 and 3)
ptarray(3) = ypoint
Set lwployobj = moSpace.AddLightWeightPolyline(ptarray)
'在AutoCAD文件里画线
With lwployobj
'.Layer = newlayer.Name '指定lwployobj所在图层
.Color = acBlue '指定lwployobj的颜色
End With
Lineweight lwployobj, ma.Borders(xlEdgeLeft).Weight
lwployobj.Update
End If
End If
If ma.Borders(xlEdgeRight).LineStyle <> xlNone Then
ptarray(0) = xpoint + xh
'第二点坐标（数组下标 0 and 1)
ptarray(1) = ypoint
ptarray(2) = xpoint + xh
'第三点坐标（数组下标 2 and 3）
ptarray(3) = ypoint - yh
Set lwployobj = moSpace.AddLightWeightPolyline(ptarray)
'在AutoCAD文件里画线
With lwployobj
'.Layer = newlayer.Name '指定lwployobj所在图层
.Color = acBlue '指定lwployobj的颜色
End With
Lineweight lwployobj, ma.Borders(xlEdgeRight).Weight
lwployobj.Update
txtHeight = c.Font.Size * 2 / 3 '字高
fptText(0) = xpoint
fptText(1) = ypoint - yh / 2 + txtHeight / 2
fptText(2) = 0
strText = c.Text
Call wz(c, strText)
Set textobj = moSpace.AddMText(fptText, xh, strText)
Call kz(textobj, c)
End If
End If '??????????????????
Next Y
Next X
End Sub
'下面程序控制线条粗细
Sub Lineweight(ByVal line As Object, u As Integer)
Select Case u
Case 1
Call line.SetWidth(0, 0.1, 0.1)
Case 2
Call line.SetWidth(0, 0.3, 0.3)
Case -4138
Call line.SetWidth(0, 0.5, 0.5)
Case 4
Call line.SetWidth(0, 1, 1)
Case Else
Call line.SetWidth(0, 0.1, 0.1)
End Select
End Sub
'下面程序完成列号转换
Function zh(pp As Integer) As String
If pp <= 26 Then
zh = Chr(64 + pp)
Else
If (pp Mod 26) = 0 Then
zh = Chr(64 + Int(pp / 26) - 1) + Chr(64 + 26)
Else
zh = Chr(64 + Int(pp / 26)) + Chr(64 + pp Mod 26)
End If
End If
End Function
Sub wz(c As Range, textStr)
Dim Char As String
Dim j As Integer
Dim cpt As String
Dim tempStr As String
Dim sonstr1 As String
Dim sonstr As String
Char = RTrim(Left(c.Characters.Caption, 256))
If Char <> Empty Then
textStr = ""
For j = 1 To Len(Char)
If c.Characters(j, 1).Font.Underline = xlUnderlineStyleNone Then
cpt = c.Characters(j, 1).Caption
sonstr = ForeFontStr(c, j)
tempStr = ""
Do While j + 1 <= Len(Char)
sonstr1 = ForeFontStr(c, j + 1)
If sonstr1 = sonstr Then
j = j + 1
tempStr = tempStr + c.Characters(j, 1).Caption
Else
Exit Do
End If
Loop
textStr = textStr + "{" + sonstr + cpt + tempStr + "}"
Else
cpt = c.Characters(j, 1).Caption
sonstr = ForeFontStr(c, j)
tempStr = ""
Do While j + 1 <= Len(Char)
sonstr1 = ForeFontStr(c, j + 1)
If sonstr1 = sonstr Then
j = j + 1
tempStr = tempStr + c.Characters(j, 1).Caption
Else
Exit Do
End If
Loop
'textStr = textStr + "{\L" + sonstr(cpt) + tempStr + "\l}" '????
textStr = textStr + "{\L" + sonstr + cpt + tempStr + "\l}" '????
End If
Next j
End If
End Sub
'下面函数控制字体本身属性
Function ForeFontStr(m As Range, u As Integer) As String
Dim a1 As String: Dim a2 As String: Dim a3 As String
Dim a4 As String: Dim a5 As String: Dim a6 As String
a1 = "\F" + m.Characters(u, 1).Font.Name + ";" '字体
a2 = IIf(m.Characters(u, 1).Font.Superscript = True, "\H0.33x;\A2;", "") '上脚标
a3 = IIf(m.Characters(u, 1).Font.Subscript = True, "\H0.33x;\A0;", "") '下脚标
a4 = IIf(m.Characters(u, 1).Font.FontStyle = "倾斜", "\Q18;", "") '倾斜
a5 = IIf(m.Characters(u, 1).Font.FontStyle = "加粗", "\W1.2;", "") '加粗
a6 = IIf(m.Characters(u, 1).Font.FontStyle = "加粗倾斜", "\W1.2;\Q18;", "") ' 加粗倾斜
ForeFontStr = a1 + a2 + a3 + a4 + a5 + a6
End Function
' ---- （2）.表格中表格文字位置的转换
' ---- 对文字对象的属性的直接控制来实现，通过with….end with
' 结构可以很容易地控制文字的高度、图层、颜色、书写方向。由于Mtext文字提供支持的排列位置分为9种，必须根据Microsoft
' Excel表格文字的排列方式加以合适的判定，然后进行转换。其具体的实现方法详见下面的程序。
Sub kz(textobj, c)
With textobj '文字对象
Dim ma As Object
Set ma = c.MergeArea
.Height = c.Font.Size * 2 / 3 'Excel文字高度换算成Acad文字高度
'.Layer = newlayer.Name '设置图层
.Color = acRed '设置颜色
.DrawingDirection = 1 '设置书写方向
If (ma.VerticalAlignment = xlTop _
Or ma.VerticalAlignment = xlGeneral) _
And (ma.HorizontalAlignment = xlLeft _
Or ma.HorizontalAlignment = xlGeneral) _
Then .AttachmentPoint = 1 'acAttachmentPointTopLeft
If (ma.VerticalAlignment = xlTop _
Or ma.VerticalAlignment = xlGeneral) _
And (ma.HorizontalAlignment = xlCenter _
Or ma.HorizontalAlignment = xlJustify _
Or ma.HorizontalAlignment = xlDistributed) _
Then .AttachmentPoint = 2 'acAttachmentPointTopCenter
If (ma.VerticalAlignment = xlTop _
Or ma.VerticalAlignment = xlGeneral) _
And ma.HorizontalAlignment = xlRight _
Then .AttachmentPoint = 3 'acAttachmentPointTopRight
If (ma.VerticalAlignment = xlCenter _
Or ma.VerticalAlignment = xlJustify _
Or ma.VerticalAlignment = xlDistributed) _
And (ma.HorizontalAlignment = xlLeft _
Or ma.HorizontalAlignment = xlGeneral) _
Then .AttachmentPoint = 4 'acAttachmentPointMiddleLeft
If (ma.VerticalAlignment = xlCenter _
Or ma.VerticalAlignment = xlJustify _
Or ma.VerticalAlignment = xlDistributed) _
And (ma.HorizontalAlignment = xlCenter _
Or ma.HorizontalAlignment = xlJustify _
Or ma.HorizontalAlignment = xlDistributed) _
Then .AttachmentPoint = 5 'acAttachmentPointMiddleCenter
If (ma.VerticalAlignment = xlCenter _
Or ma.VerticalAlignment = xlJustify _
Or ma.VerticalAlignment = xlDistributed) _
And ma.HorizontalAlignment = xlRight _
Then .AttachmentPoint = 6 'acAttachmentPointMiddleRight
If ma.VerticalAlignment = xlBottom _
And (ma.HorizontalAlignment = xlLeft _
Or ma.HorizontalAlignment = xlGeneral) _
Then .AttachmentPoint = 7 'acAttachmentPointBottomLeft
If ma.VerticalAlignment = xlBottom _
And (ma.HorizontalAlignment = xlCenter _
Or ma.HorizontalAlignment = xlJustify _
Or ma.HorizontalAlignment = xlDistributed) _
Then .AttachmentPoint = 8 'acAttachmentPointBottomCenter
If ma.VerticalAlignment = xlBottom _
And ma.HorizontalAlignment = xlRight _
Then .AttachmentPoint = 9 'acAttachmentPointBottomRight
End With
textobj.Update
End Sub

'                ExcelToCad 
' 
'********************************************************************** 
'原作: 
'        计算机世界报　　新疆交通科学研究所　 查拥军 
'                "利用VBA编程实现从EXCEL表到AUTOCAD表转换" 
'********************************************************************** 
'改编: 
'        zhqchn 
'********************************************************************** 
'简介: 
'            如何将Excel的制表计算与AutoCad的绘图功能结合，是很多人关心的问题 
'        Atable的出现以及unionsoft的TrueTable的迅速成熟为大家解决了大问题 
'        本人曾动过开发类似软件的念头，但接触TrueTable后就觉得没有必要了。 
'            前段时间看到有网友将查拥军的这篇文章贴到论坛，引来了不少关注， 
'        说明还是有不少人不满足于现成的工具，希望搞清原理，而查先生的程序 
'        只是摘录，也可能是故意隐去一些东西，因此不能直接运行，我将此程序 
'        做了修正，并加了一些注释,使有兴趣的初学者更容易调试，便于学习。 
'            我只是在原程序的基础是修正一些错误，程序还有很多不完善的地方， 
'        水平有限，高手莫笑话。 
'            程序请从cmdTableToExcel_Click运行，hxw中的Call wz(c, strText) 
'        是控制文字样式的，若打开，程序运行会很慢。 
'*********************************************************************** 
' 
 
Option Explicit 
 
 
Private Sub cmdTableToExcel_Click() 
    Call ConnectCAD 
    Call ConnectEXCEL 
    Call tableToExcel 
End Sub 
 
Sub tableToExcel() 
    Call hxw 
End Sub 
 
      '---- 在AutoCAD中，线条有多种，考虑能够方便控制线条属性，选用了多义线。具体命令如下： RetVal =object.AddLightWeightPolyline (VerticesList) 
      '---- 下面的程序演示表格线条读取和画表格线的具体过程。 
Sub hxw() 
    Dim a As Integer '表格的最大行数 
    Dim b As Integer '表格的最大列数 
    Dim xinit As Double '插入点x坐标 
    Dim yinit As Double '插入点y坐标 
    Dim zinit As Double '插入点z坐标 
    Dim xinsert As Double '当前单元格的左上角点的x左标 
    Dim yinsert As Double '当前单元格的左上角点的y左标 
    Dim ptarray(0 To 3) As Double   '画表格线(lwpolyline)的顶点坐标 
    Dim X As Integer    '循环变量(表格行) 
    Dim Y As Integer    '循环变量(表格列) 
    
    Dim c As Object     '单元格地址 
    Dim ma As Object    '合并单元格 
    Dim xl As Variant 
    Dim xh As Integer   '单元格宽 
    Dim yh As Integer   '单元格高 
    Dim xlRange As Object 
    Dim xpoint As Double    '当前单元格的左上角点的x左标(已加上插入点x坐标) 
    Dim ypoint As Double    '当前单元格的左上角点的y左标(已加上插入点y坐标) 
    Dim lwployobj As AcadLWPolyline '多义线 
    Dim textobj As AcadMText         '文本 
    Dim fptText(0 To 2) As Double   '文本插入点 
    Dim strText As String           '文本内容 
    Dim txtHeight As Double         '文本高度 
    
    a = xlApp.Selection.Rows.Count 
    b = xlApp.Selection.Columns.Count 
    
    
    For X = 1 To a 
        For Y = 1 To b 
            Set c = xlSht.Range(zh(Y) + Trim(str(X))) 
            '以行号、列号获得单元格地址 
            Set ma = c.MergeArea 
            '求出单元格C的合并单元格地址 
            Dim tempStr As String 
            tempStr = Trim(ma.Address) 
            If ma.Count > 1 Then tempStr = Divide(Trim(ma.Address), ":", 0) 
            If tempStr = Trim(c.Address) Then 
                '假如c.mergearea的绝对地址 , 如果前4个字符与c单元格的地址相同 
                xl = "A1:" + ma.Address 
                xh = xlSht.Range(ma.Address).Width 
                yh = xlSht.Range(ma.Address).Height 
                Set xlRange = xlSht.Range(xl) 
                xinsert = xlRange.Width - xh 
                yinsert = xlRange.Height - yh 
                xpoint = xinit + xinsert 
                ypoint = yinit - yinsert 
                If X = 1 Then               '第一行 
                    If ma.Borders(xlEdgeTop).LineStyle <> xlNone Then 
                        ptarray(0) = xpoint 
                        '第一点坐标（数组下标 0 and 1) 
                        ptarray(1) = ypoint 
                        ptarray(2) = xpoint + xh 
                        '第二点坐标（数组下标 2 and 3) 
                        ptarray(3) = ypoint 
                         
                        Set lwployobj = moSpace.AddLightWeightPolyline(ptarray) 
                        '在AutoCAD文件里画线 
                        With lwployobj 
                            '.Layer = newlayer.Name '指定lwployobj所在图层 
                            .Color = acBlue   '指定lwployobj的颜色 
                        End With 
                        Lineweight lwployobj, ma.Borders(xlEdgeTop).Weight 
                        lwployobj.Update 
                    End If 
                End If 
                If ma.Borders(xlEdgeBottom).LineStyle <> xlNone Then 
                    ptarray(0) = xpoint + xh 
                    '第三点坐标（数组下标 0 and 1) 
                    ptarray(1) = ypoint - yh 
                    ptarray(2) = xpoint 
                    '第四点坐标（数组下标 2 and 3） 
                     ptarray(3) = ypoint - yh 
                    Set lwployobj = moSpace.AddLightWeightPolyline(ptarray) 
                    '在AutoCAD文件里画线 
                    With lwployobj 
                        '.Layer = newlayer.Name '指定lwployobj所在图层 
                        .Color = acBlue   '指定lwployobj的颜色 
                    End With 
                    Lineweight lwployobj, ma.Borders(xlEdgeBottom).Weight 
                    lwployobj.Update 
                End If 
                
                
                
                If Y = 1 Then               '第一列 
                    If ma.Borders(xlEdgeLeft).LineStyle <> xlNone Then 
                       ptarray(0) = xpoint 
                       '第四点坐标（数组下标 0 and 1) 
                       ptarray(1) = ypoint - yh 
                       ptarray(2) = xpoint 
                       '第一点坐标（数组下标 2 and 3) 
                        ptarray(3) = ypoint 
                         
                        Set lwployobj = moSpace.AddLightWeightPolyline(ptarray) 
                        '在AutoCAD文件里画线 
                        With lwployobj 
                            '.Layer = newlayer.Name '指定lwployobj所在图层 
                            .Color = acBlue   '指定lwployobj的颜色 
                        End With 
                        Lineweight lwployobj, ma.Borders(xlEdgeLeft).Weight 
                        lwployobj.Update 
                    End If 
                End If 
                If ma.Borders(xlEdgeRight).LineStyle <> xlNone Then 
                    ptarray(0) = xpoint + xh 
                    '第二点坐标（数组下标 0 and 1) 
                    ptarray(1) = ypoint 
                    ptarray(2) = xpoint + xh 
                    '第三点坐标（数组下标 2 and 3） 
                    ptarray(3) = ypoint - yh 
                     
                    Set lwployobj = moSpace.AddLightWeightPolyline(ptarray) 
                    '在AutoCAD文件里画线 
                    With lwployobj 
                        '.Layer = newlayer.Name '指定lwployobj所在图层 
                        .Color = acBlue   '指定lwployobj的颜色 
                    End With 
                    Lineweight lwployobj, ma.Borders(xlEdgeRight).Weight 
                    lwployobj.Update 
                     
                    txtHeight = c.Font.Size * 2 / 3     '字高 
                    fptText(0) = xpoint 
                    fptText(1) = ypoint - yh / 2 + txtHeight / 2 
                    fptText(2) = 0 
                    strText = c.Text 
 
                    Call wz(c, strText) 
                     
                    Set textobj = moSpace.AddMText(fptText, xh, strText) 
                     
                    Call kz(textobj, c) 
                     
                End If 
            End If                  '?????????????????? 
        Next Y 
    Next X 
End Sub 
'下面程序控制线条粗细 
Sub Lineweight(ByVal line As Object, u As Integer) 
    Select Case u 
        Case 1 
            Call line.SetWidth(0, 0.1, 0.1) 
        Case 2 
            Call line.SetWidth(0, 0.3, 0.3) 
        Case -4138 
            Call line.SetWidth(0, 0.5, 0.5) 
        Case 4 
            Call line.SetWidth(0, 1, 1) 
        Case Else 
            Call line.SetWidth(0, 0.1, 0.1) 
    End Select 
End Sub 
'下面程序完成列号转换 
Function zh(pp As Integer) As String 
    If pp <= 26 Then 
        zh = Chr(64 + pp) 
    Else 
        If (pp Mod 26) = 0 Then 
            zh = Chr(64 + Int(pp / 26) - 1) + Chr(64 + 26) 
        Else 
            zh = Chr(64 + Int(pp / 26)) + Chr(64 + pp Mod 26) 
        End If 
    End If 
End Function 
 
 
Sub wz(c As Range, textStr) 
    Dim Char As String 
    Dim j As Integer 
    Dim cpt As String 
    Dim tempStr As String 
    Dim sonstr1 As String 
    Dim sonstr As String 
    
    Char = RTrim(Left(c.Characters.Caption, 256)) 
    If Char <> Empty Then 
        textStr = "" 
        For j = 1 To Len(Char) 
            If c.Characters(j, 1).Font.Underline = xlUnderlineStyleNone Then 
                cpt = c.Characters(j, 1).Caption 
                sonstr = ForeFontStr(c, j) 
                tempStr = "" 
                Do While j + 1 <= Len(Char) 
                     sonstr1 = ForeFontStr(c, j + 1) 
                     If sonstr1 = sonstr Then 
                        j = j + 1 
                        tempStr = tempStr + c.Characters(j, 1).Caption 
                     Else 
                        Exit Do 
                     End If 
                Loop 
                textStr = textStr + "{" + sonstr + cpt + tempStr + "}" 
            Else 
                cpt = c.Characters(j, 1).Caption 
                sonstr = ForeFontStr(c, j) 
                tempStr = "" 
                Do While j + 1 <= Len(Char) 
                    sonstr1 = ForeFontStr(c, j + 1) 
                    If sonstr1 = sonstr Then 
                       j = j + 1 
                       tempStr = tempStr + c.Characters(j, 1).Caption 
                    Else 
                       Exit Do 
                    End If 
                Loop 
                'textStr = textStr + "{\L" + sonstr(cpt) + tempStr + "\l}"        '???? 
                textStr = textStr + "{\L" + sonstr + cpt + tempStr + "\l}"      '???? 
            End If 
        Next j 
    End If 
End Sub 
'下面函数控制字体本身属性 
Function ForeFontStr(m As Range, u As Integer) As String 
    Dim a1 As String: Dim a2 As String: Dim a3 As String 
    Dim a4 As String: Dim a5 As String: Dim a6 As String 
    a1 = "\F" + m.Characters(u, 1).Font.Name + ";"  '字体 
    a2 = IIf(m.Characters(u, 1).Font.Superscript = True, "\H0.33x;\A2;", "") '上脚标 
    a3 = IIf(m.Characters(u, 1).Font.Subscript = True, "\H0.33x;\A0;", "") '下脚标 
    a4 = IIf(m.Characters(u, 1).Font.FontStyle = "倾斜", "\Q18;", "") '倾斜 
    a5 = IIf(m.Characters(u, 1).Font.FontStyle = "加粗", "\W1.2;", "")  '加粗 
    a6 = IIf(m.Characters(u, 1).Font.FontStyle = "加粗 倾斜", "\W1.2;\Q18;", "") ' 加粗倾斜 
    ForeFontStr = a1 + a2 + a3 + a4 + a5 + a6 
End Function 
 
     ' ---- （2）.表格中表格文字位置的转换 
     ' ---- 对文字对象的属性的直接控制来实现，通过with….end with 
     ' 结构可以很容易地控制文字的高度、图层、颜色、书写方向。由于Mtext文字提供支持的排列位置分为9种，必须根据Microsoft 
     ' Excel表格文字的排列方式加以合适的判定，然后进行转换。其具体的实现方法详见下面的程序。 
Sub kz(textobj, c) 
    With textobj '文字对象 
        Dim ma As Object 
        Set ma = c.MergeArea 
        .Height = c.Font.Size * 2 / 3       'Excel文字高度换算成Acad文字高度 
        '.Layer = newlayer.Name  '设置图层 
        .Color = acRed          '设置颜色 
        .DrawingDirection = 1    '设置书写方向 
       If (ma.VerticalAlignment = xlTop _ 
           Or ma.VerticalAlignment = xlGeneral) _ 
           And (ma.HorizontalAlignment = xlLeft _ 
           Or ma.HorizontalAlignment = xlGeneral) _ 
           Then .AttachmentPoint = 1  'acAttachmentPointTopLeft 
       If (ma.VerticalAlignment = xlTop _ 
           Or ma.VerticalAlignment = xlGeneral) _ 
           And (ma.HorizontalAlignment = xlCenter _ 
           Or ma.HorizontalAlignment = xlJustify _ 
           Or ma.HorizontalAlignment = xlDistributed) _ 
           Then .AttachmentPoint = 2  'acAttachmentPointTopCenter 
       If (ma.VerticalAlignment = xlTop _ 
           Or ma.VerticalAlignment = xlGeneral) _ 
           And ma.HorizontalAlignment = xlRight _ 
           Then .AttachmentPoint = 3  'acAttachmentPointTopRight 
       If (ma.VerticalAlignment = xlCenter _ 
           Or ma.VerticalAlignment = xlJustify _ 
           Or ma.VerticalAlignment = xlDistributed) _ 
           And (ma.HorizontalAlignment = xlLeft _ 
           Or ma.HorizontalAlignment = xlGeneral) _ 
           Then .AttachmentPoint = 4  'acAttachmentPointMiddleLeft 
       If (ma.VerticalAlignment = xlCenter _ 
           Or ma.VerticalAlignment = xlJustify _ 
           Or ma.VerticalAlignment = xlDistributed) _ 
           And (ma.HorizontalAlignment = xlCenter _ 
           Or ma.HorizontalAlignment = xlJustify _ 
           Or ma.HorizontalAlignment = xlDistributed) _ 
           Then .AttachmentPoint = 5  'acAttachmentPointMiddleCenter 
       If (ma.VerticalAlignment = xlCenter _ 
           Or ma.VerticalAlignment = xlJustify _ 
           Or ma.VerticalAlignment = xlDistributed) _ 
           And ma.HorizontalAlignment = xlRight _ 
           Then .AttachmentPoint = 6 'acAttachmentPointMiddleRight 
       If ma.VerticalAlignment = xlBottom _ 
           And (ma.HorizontalAlignment = xlLeft _ 
           Or ma.HorizontalAlignment = xlGeneral) _ 
           Then .AttachmentPoint = 7  'acAttachmentPointBottomLeft 
      If ma.VerticalAlignment = xlBottom _ 
           And (ma.HorizontalAlignment = xlCenter _ 
           Or ma.HorizontalAlignment = xlJustify _ 
           Or ma.HorizontalAlignment = xlDistributed) _ 
           Then .AttachmentPoint = 8  'acAttachmentPointBottomCenter 
      If ma.VerticalAlignment = xlBottom _ 
           And ma.HorizontalAlignment = xlRight _ 
           Then .AttachmentPoint = 9  'acAttachmentPointBottomRight 
    End With 
    textobj.Update 
End Sub

这是Excel表格

zhqchn · 发表于 2003-9-3 20:18:54

这是画到Cad中的情况

ntchjie · 发表于 2003-9-16 15:40:13

合并单元格是这一块的难点，这个问题能够解决，很好，顶一下。

cwq_1978 · 发表于 2003-11-30 04:21:19

不好意思，我是新手。程序运行的时候，怎么会出现错误？说 "变量为定义",怎么回事？

lhjlyy0 · 发表于 2004-8-19 00:37:23

谢谢了，我才学习编程

地鼠 · 发表于 2005-11-13 16:40:14

Call ConnectCAD
Call ConnectEXCEL

这两个函数没有定义。请问如何解决？
是不是代码也不全？

mountains3 · 发表于 2005-11-17 08:45:36

如果真要学习的话，可以去看本人在本版所发帖子“excel表格转cad(速度快20倍)”,里面的代码在excel单元格处理以及速度方面都要略胜一筹，你可以对比两者的速度及效果。

lgmandy · 发表于 2005-11-17 13:55:59

这个帖子“excel表格转cad(速度快20倍)”，真的很不错

gucci218 · 发表于 2006-5-28 00:23:24

楼主能作个加载运行的动画吗，好像不能运行，提示：编译错误，用户定义类型未定义

zxhliu · 发表于 2006-7-23 01:13:36

7楼的帖子还要收钱呀。

jx2008 · 发表于 2007-7-6 08:57:43

翻译成vlisp的代码就好了，楼上的程序能够合并单元格，非常好，blisp中能够合并单元格，设置对齐等格式就好了

raobinhsh · 发表于 2007-7-31 08:53:05

我原下载过这么一个程序，可以把EXCEL表格转换成CAD中的表格，但因为知识产权的原因，我们不能用微软的EXCEL了，只能用金山的EXCEL，而我下载的那个把EXCEL表格转换成CAD中的表格的工具就不能用了，不知这个程序有办法吗

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

[VBA程序]：利用VBA编程实现从EXCEL表到AUTOCAD表转换

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子