|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
下载使用了其中的一些，但存在比较多的问题，不知是不是版主在整理转换成CHM格式的时候丢失了一小儿代码和符号，导致无法运行或者运行中断。希望版主告知，受柔版主的PDF版的链接。O(∩_∩)O谢谢。错误比如：
四十五) 乾坤大挪移
对正常方向字体进行挪移，并可设置框线类型及文本从右到左或者从左到右，从上到下或者从下到上，对竖排字体（适用一种并受WORD表格限制，仅在字数300~500字左右进行装裱可达到类似书法贴或古籍效果,可进一步完善），横排字数不限。
'* +++++++++++++++++++++++++++++++++++++++
'^代码复制到 [标准模块-模块1]^'
'* ---------------------------------------
Public Sz As Byte, Bor As Byte, Rl As Byte, Ud As Byte
Sub SetUnderline()
Dim i As Integer, FilName As String, FilPath As String, LisValue As String
Dim LineOf As Integer, Orient As Byte, Y As Long, MyText As String
Dim NewDoc As Document, NewTable As Table, n As Integer, X As Long
On Error GoTo ErrorHandle
Application.ScreenUpdating = False
With ActiveDocument
.Content.Font.Size = Sz * 1.1
FilPath = .Path
FilName = .Name
Orient = .Content.Orientation
CommandBars("Word Count").Visible = True
CommandBars("Word Count").Controls(2).Execute
LisValue = CommandBars("Word Count").Controls(1).List(6)
CommandBars("Word Count").Visible = False
LineOf = Int(Mid(LisValue, 1, Len(LisValue) - 1))
End With
Set NewDoc = Documents.Add
With NewDoc
.SaveAs FileName:=FilPath & "\U" & FilName
Set NewTable = .Tables.Add(Range:=Selection.Range, NumRows:=IIf(Orient = 0, LineOf, 1), NumColumns:=IIf(Orient = 0, 1, LineOf))
End With
Documents(FilName).Activate
With ActiveDocument
.Range(0, 0).Select
For n = 1 To LineOf
Selection.EndKey unit:=wdLine
Selection.HomeKey unit:=wdLine, Extend:=wdExtend
MyText = IIf(Rl = 0, Selection, StrReverse(Selection))
NewTable.Cell(IIf(Orient = 0, IIf(Ud = 0, n, LineOf - n + 1), 1), IIf(Orient = 0, 1, IIf(Ud = 0, n, LineOf - n + 1))).Range.Text = MyText
Selection.MoveDown unit:=wdLine, Count:=1
Next n
End With
With NewDoc
.Activate .Tables(1).Select
.PageSetup.Orientation = IIf(Orient = 1, wdOrientLandscape, wdOrientPortrait)
With Options
.DefaultBord
erLineStyle = wdLineStyleSingle
.DefaultBorderLineWidth = wdLineWidth050pt
.DefaultBorderColor = wdColorRed
End With
Select Case Bor
Case 0
Application.Run "BorderBottom"
Application.Run "BorderHoriz"
Case 1
Application.Run "BorderAll"
End Select
.Content.Font.Size = Sz
End With
Documents(FilName).Content.Font.Size = Sz
Application.ScreenUpdating = True
Exit Sub
ErrorHandle:
MsgBox "Word遇到不可预测性错误，本程序将不能正确执行，请检查后再运行！"
Exit Sub
End Sub
'----------------------
Sub ShowMe()
UserForm1.Show
End Sub
'----------------------
'* +++++++++++++++++++++++++++++++++++++++
'^代码复制到 [用户窗体-UserForm1]^'
'* ---------------------------------------
Private Sub CommandButton1_Click()
On Error Resume Next
With Me
.Hide
Sz = .ComboBox1.ListIndex + 5
Bor = .ComboBox2.ListIndex
Rl = .ComboBox3.ListIndex
Ud = .ComboBox4.ListIndex
If .ComboBox2.Value = "More" Then
MsgBox "Word注意到:您选取的框线为More,更多框线设置请在完成本功能后在目标文件的格式/边框和底纹中进行！"
End If
End With
Call SetUnderline
End Sub
'----------------------
Private Sub UserForm_Activate()
On Error Resume Next
With Me
.ComboBox1.ListIndex = 7
.ComboBox2.ListIndex = 0
.ComboBox3.ListIndex = 0
.ComboBox4.ListIndex = 0
.CommandButton1.Default = True
End With
End Sub
'----------------------
Private Sub UserForm_Initialize()
Dim i As Byte
On Error Resume Next
With Me.ComboBox1
For i = 5 To 30
.AddItem i
Next i
End With
With Me.ComboBox2
.AddItem "下框线"
.AddItem "全框线"
.AddItem "More"
End With
With Me.ComboBox3
.AddItem "从左至右"
.AddItem "从右向左"
End With
With Me.ComboBox4
.AddItem "从上至下"
.AddItem "从下向上"
End With
End Sub
'----------------------
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
Cancel = True '关闭无效
End Sub |
|
楼主: yj5354
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2010-6-29 23:20
