Sub hxw()
Dim a As interger '表格的最大行数Dim b As interger '表格的最大列数
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 2) As Double
Dim x As Integer
Dim y As Integer
For x = 1 To a
For y = 1 To b
Set c = xlsheet.Range(zh(y) + Trim(Str(x)))
'以行号、列号获得单元格地址
Set ma = c.MergeArea
'求出单元格C的合并单元格地址
If Left(Trim(ma.Address), 4) = Trim(c.Address) Then
假如c.mergearea的绝对地址 , 如果前4个字符与c单元格的地址相同
xl = "A1:" + ma.Address
xh = xlsheet.Range(ma.Address).Width
yh = xlsheet.Range(ma.Address).Height
Set xlrange = xlsheet.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
End IfLineweight lwployobj, ma.Borders(xlEdgeTop).Weight
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
Lineweight lwployobj
ma.Borders(xlEdgeBottom).Weight
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
End If
Lineweight lwployobj, ma.Borders(xlEdgeLeft).Weight
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
Lineweight lwployobj
ma.Borders(xlEdgeRight).Weight
End If
Set lwployobj = moSpace.AddLightWeightPolyline(ptarray)
'在AutoCAD文件里画线
With lwployobj.Layer = newlayer.Name
'指定lwployobj所在图层
.color = acBlue '指定lwployobj的颜色
End With
lwployobj.Update
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
zh = Chr(64 + Int(pp / 26)) + Chr(64 + pp Mod 26)
End If
End Function' 3、表格文字转换'表格文字转换包括表格文字本身转换和表格文字在表格中位置的转换两个部分。'在AutoCAD中，文字标注的形式有多种，与Microsoft Excel 单元格区域多行文本内容相对应的是多行文本命令。AutoCAD提供的VBA添加多行文本的命令语句是：RetVal = object.AddMText(InsertionPoint, Width, Text)'通过修改RetVal的属性可以控制表格文字在表格中的位置。'(1)．表格文字本身的转换'分析AddMText命令可以得出：表格文字所在位置、文字内容宽度，文字内容，均可通过此命令来添加。然而表格文字字体，大小，下划线、上下脚标，倾斜，加粗等却不能。一般的方法是采用修改字体形文件的方法来实现，方法烦琐，不便于实现，而且仅对修改过形文件的字体有效。况且当同一文字块内的不同文字的字体，大小，下划线、上下脚标，倾斜，加粗不同时，使用修改字体形文件的方法也无法实现。本文介绍一种直接利用Mtext命令提供的方法进行转换。'在AddMText命令中，影响文字内容和文字属性的参数Text。在具体文字前加上一定的控制符号可以控制文字的文字属性，具体控制符号可以参阅AutoCAD帮助文件。例如，{\F宋体；\Q18;\W1.2;ABCDEFG}把“ABCDEFG”设置成宋体、向右倾斜18度，每个字的宽度是正常宽度1.2倍。'本程序具体采用的方法是：读取Microsoft Excel文件某一单元格区域里的某第j个字符属性（字体，大小，下划线、上、下脚标，倾斜，加粗），读取Microsoft Excel文件某一单元格区域里的某第j+1个字符属性，如果与第j个字符相同，则二者采用同样的控制符号；若不同，则从第j+1个字符开始，重复前面的工作。Sub wz()
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}"
End If
Next j
End If
End Sub
'下面函数控制字体本身属性
Function ForeFontStr(m As Range, u As Integer) 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()
With textObj '文字对象
.Height = textHgt
.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
Dim a As interger '表格的最大行数Dim b As interger '表格的最大列数
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 2) As Double
Dim x As Integer
Dim y As Integer
For x = 1 To a
For y = 1 To b
Set c = xlsheet.Range(zh(y) + Trim(Str(x)))
'以行号、列号获得单元格地址
Set ma = c.MergeArea
'求出单元格C的合并单元格地址
If Left(Trim(ma.Address), 4) = Trim(c.Address) Then
假如c.mergearea的绝对地址 , 如果前4个字符与c单元格的地址相同
xl = "A1:" + ma.Address
xh = xlsheet.Range(ma.Address).Width
yh = xlsheet.Range(ma.Address).Height
Set xlrange = xlsheet.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
End IfLineweight lwployobj, ma.Borders(xlEdgeTop).Weight
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
Lineweight lwployobj
ma.Borders(xlEdgeBottom).Weight
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
End If
Lineweight lwployobj, ma.Borders(xlEdgeLeft).Weight
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
Lineweight lwployobj
ma.Borders(xlEdgeRight).Weight
End If
Set lwployobj = moSpace.AddLightWeightPolyline(ptarray)
'在AutoCAD文件里画线
With lwployobj.Layer = newlayer.Name
'指定lwployobj所在图层
.color = acBlue '指定lwployobj的颜色
End With
lwployobj.Update
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
zh = Chr(64 + Int(pp / 26)) + Chr(64 + pp Mod 26)
End If
End Function' 3、表格文字转换'表格文字转换包括表格文字本身转换和表格文字在表格中位置的转换两个部分。'在AutoCAD中，文字标注的形式有多种，与Microsoft Excel 单元格区域多行文本内容相对应的是多行文本命令。AutoCAD提供的VBA添加多行文本的命令语句是：RetVal = object.AddMText(InsertionPoint, Width, Text)'通过修改RetVal的属性可以控制表格文字在表格中的位置。'(1)．表格文字本身的转换'分析AddMText命令可以得出：表格文字所在位置、文字内容宽度，文字内容，均可通过此命令来添加。然而表格文字字体，大小，下划线、上下脚标，倾斜，加粗等却不能。一般的方法是采用修改字体形文件的方法来实现，方法烦琐，不便于实现，而且仅对修改过形文件的字体有效。况且当同一文字块内的不同文字的字体，大小，下划线、上下脚标，倾斜，加粗不同时，使用修改字体形文件的方法也无法实现。本文介绍一种直接利用Mtext命令提供的方法进行转换。'在AddMText命令中，影响文字内容和文字属性的参数Text。在具体文字前加上一定的控制符号可以控制文字的文字属性，具体控制符号可以参阅AutoCAD帮助文件。例如，{\F宋体；\Q18;\W1.2;ABCDEFG}把“ABCDEFG”设置成宋体、向右倾斜18度，每个字的宽度是正常宽度1.2倍。'本程序具体采用的方法是：读取Microsoft Excel文件某一单元格区域里的某第j个字符属性（字体，大小，下划线、上、下脚标，倾斜，加粗），读取Microsoft Excel文件某一单元格区域里的某第j+1个字符属性，如果与第j个字符相同，则二者采用同样的控制符号；若不同，则从第j+1个字符开始，重复前面的工作。Sub wz()
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}"
End If
Next j
End If
End Sub
'下面函数控制字体本身属性
Function ForeFontStr(m As Range, u As Integer) 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()
With textObj '文字对象
.Height = textHgt
.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
Dim b As interger '表格的最大列数Integer