|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
请帮助改正下面宏中错误。谢谢
Sub 米字格()
'
' 米字格 Macro
' 宏在 02-6-21 由 aaa 创建
'word to tb 0
Dim plefy As Long
Dim ptop As Long
Dim ydsize As Long
Dim tdspace As Long
'文本框边距(默认2磅)
tdspace = InputBox("请输入文本框边距", , 2)
'本次转换以前图形对象数
Countl = ActiveDocument.Shapes.Count
'起点(所迁文字第一个字符相对页面的水平、垂直距离)
Pleft = Selection.Information(wdHorizontalPositionRelativeToPage)
plop = Selection.Information(wdVerticalPositionRelativeToPage)
'所选文字的大小
fSize = Selection.Font.Size
'文本框的大小
tdSize = fSize + tdspace * 2
'返回所选文字的字符格式
Set DupFOnt = Selection.Font.Duplicate
'返回所选文字的文本(无格式)
tStr = Selection.Text
'返回所先文字的字符个数
slen = Len(pStr)
'删除所选文字
Selection.Delete
'逐字填入“米”字格
For i = i To slen
'当前要创建文本框的起点(为了简化程序并且从实际出发,没有考虑换行)
tdleft = Pleft + tdSize * (i - 1)
'创建一个文本框
set tShape = ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, tbLeft, pTop, tbSize, tbSize) tShape.Name = "TBl"
'设置文本框文字
With tShape.TextFrame
'向文本区添加一个文字
.TextRange.Text = Mid(pStr, i, 1)
'将文本区文字的格式设置成原来所选文字的格式
TextRange.Font = DupFOnt
'设置固定行高和具体磅值
.TextRange.ParagraphFormat .LineSpacingRule = wdLineSpaceExactly
'TextRange.ParagraphFormat.
LineSpacing = fSize
'设置文本框边距
.MarginBottom = tbSpace
.MarginLeft = tbSpace
.MarginRight = tbSpace
.MarginTop = tbSpace
End With
'画“米”字格的4条线
With ActiveDocument.Shapes
.AddLine(tbLeft, ptop, tbLeft + tbSize, ptop + tbSize).Name = "Lin1"
.AddLine(tbLeft, ptop, tbLeft + tbSize, tbLeft + tbSize, ptop).Name = "Lin2"
.AddLine(tbLeft, ptop + ptop + tbSize / 2, tbLeft + tbSize, ptop + tbSize / 2).Name = "Lin3"
.AddLine(tbLeft + tbSize / 2, ptop, tbLeft + tbSize / 2, ptop + tbSize).Name = "Lin4"
'组合的“米”字线命名为R1,线型设置为虚线
With .Range(Array("Lin1", "Lin2", "Lin3", "Lin4")).Group
.Name = "R1"
.Line.DashStyle = msoLineSquareDot
End With
End With
'把文本框和米字线组合
ActiveDocument.Shapes.Range(Array("TB1", "R1")).Group.Select
Next i
'本次转换以后文本框组合前图表对象数
Count2 = ActiveDocument.Shapes.Count
'如果只处理一个文字不用再组合
If Count2 - Count1 > 1 Then
'组合生成的所有图形对象并且选中
Do
ActiveDocument.Shapes.Range(Array(Count1 + 1, Count1 + 2)).Group.Select
'上一语句执行前多一个图形对象(这次的图形对象全部组合成一个了)
Loop While Count3 > Count1 + 1
End If
'设置成紧密型环绕
Seleion.ShapeRange.WrapFormat.Type = wdWrapTight
End Sub |
|