ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 19182|回复: 27

[原创]乾坤大挪移

[复制链接]

TA的精华主题

TA的得分主题

发表于 2004-8-22 09:04 | 显示全部楼层 |阅读模式
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册

XvfYYkni.rar (19.32 KB, 下载次数: 470)

以前曾有很多网友不满Word中下划线与字体间距,有几种方法可以解决,包括以前我也曾做过一个小程序。

这次这个程序的解决思路是将在文档中每行文字转移到表格中(所以称之为乾坤大挪移),利用表格线进行下划线设置。

此程序功能:对正常方向字体进行挪移,并可设置框线类型及文本从右到左或者从左到右,从上到下或者从下到上,对竖排字体(适用一种并受WORD表格限制,仅在字数300~500字左右进行装裱可达到类似书法贴或古籍效果,可进一步完善),横排字数不限。

打开该文档后点击菜单栏右侧的“运行本程序“即可,或运行宏:showme.

更多的设置可利用WORD程序中的表格属性、边框与底纹进行设置。

TA的精华主题

TA的得分主题

 楼主| 发表于 2004-8-22 09:07 | 显示全部楼层

VBA:pd:shourou

以下为源代码供参考:

Private Sub CommandButton1_Click() On Error Resume Next Me.Hide Sz = Me.ComboBox1.ListIndex + 5 Bor = Me.ComboBox2.ListIndex Rl = Me.ComboBox3.ListIndex Ud = Me.ComboBox4.ListIndex If Me.ComboBox2.Value = "More" Then MsgBox "Word注意到:您选取的框线为More,更多框线设置请在完成本功能后在目标文件的格式/边框和底纹中进行!" Call SetUnderline End Sub

‘-------------------------------------------------------------------------------------------------------------- Private Sub UserForm_Activate() On Error Resume Next Me.ComboBox1.ListIndex = 7 Me.ComboBox2.ListIndex = 0 Me.ComboBox3.ListIndex = 0 Me.ComboBox4.ListIndex = 0 Me.CommandButton1.Default = True 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 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 ‘--------------------------------------------------------------------------------------------------------

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, LineOf As Integer, Orient As Byte Dim NewDoc As Document, NewTable As Table, n As Integer, X As Long, Y As Long, MyText As String 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 End With With NewDoc .Activate .Tables(1).Select .PageSetup.Orientation = IIf(Orient = 1, wdOrientLandscape, wdOrientPortrait) With Options .DefaultBorderLineStyle = 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

TA的精华主题

TA的得分主题

发表于 2004-8-22 21:46 | 显示全部楼层

好。。。

请问:如何在文档左侧显示行数?

TA的精华主题

TA的得分主题

 楼主| 发表于 2004-8-23 07:27 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2004-8-23 20:27 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助

很不错得功能

记得以前看过一片文章,讲的好像是在需加下划线的字符两头各加一个空格,怎么设置一下就可以控制下划线和字符的距离,具体操作不记得了

TA的精华主题

TA的得分主题

发表于 2004-8-24 16:00 | 显示全部楼层

版主的水平越来越高了,使用起来挺爽的。

如果能选择仅对选中文档内容加下划线将更好。

期待版主的新作……

TA的精华主题

TA的得分主题

发表于 2004-8-24 16:59 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册

奇怪,我怎么运行不了呢?我把宏的安全性设置成低都运行不了,怎么回事?

TA的精华主题

TA的得分主题

 楼主| 发表于 2004-8-25 05:42 | 显示全部楼层
以下是引用sailorgg在2004-8-24 16:00:00的发言:

版主的水平越来越高了,使用起来挺爽的。

如果能选择仅对选中文档内容加下划线将更好。

期待版主的新作……

一个不错的主意!

以下代码更为精简,但速度可能较上述有所缓慢。注意,以下代码内容仅适用于从横排文本,并取消了第一个贴子中的从上至下从向至上以及从右及左的功能。

Sub SetBorders() Dim LisValue As String, LineOf As Integer, NewTable As Table, StartRange As Long, i As Integer Dim FontSize As Single, aCell As Cell On Error Resume Next With Selection If .End > .Start Then StartRange = .Start Else StartRange = 0 End If Bor = MsgBox("请预置框线类型,Yes为下框线,No为表格线", vbYesNo + vbDefaultButton1 + vbInformation) Application.ScreenUpdating = False FontSize = .Font.Size .Font.Size = FontSize * 1.06 Application.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)) ActiveDocument.Range(StartRange, StartRange).Select .EndKey Unit:=wdLine, Extend:=wdExtend For i = 1 To LineOf Set NewTable = .ConvertToTable(Separator:=wdSeparateByParagraphs, NumColumns:=1, _ NumRows:=1, AutoFitBehavior:=wdAutoFitFixed) .MoveDown Unit:=wdLine, Count:=1 .EndKey Unit:=wdLine, Extend:=wdExtend Next NewTable.Select Select Case Bor Case vbYes Application.Run "BorderBottom" Application.Run "BorderHoriz" Case vbNo Application.Run "BorderAll" End Select .Font.Size = FontSize End With For Each aCell In NewTable.Range.Cells If Len(aCell.Range.Text) <= 4 Then aCell.Delete End If Next Application.ScreenUpdating = True End Sub

[此贴子已经被作者于2004-8-25 5:43:00编辑过]

TA的精华主题

TA的得分主题

发表于 2004-8-27 20:56 | 显示全部楼层

在版主的启发下自己写了一个自动加下划线的代码(其中参考版主的部分代码):

Sub 自动加下划线() Dim lineof, i As Integer With Selection .HomeKey unit:=wdStory 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)) .EndKey unit:=wdLine For i = 1 To lineof .EndKey unit:=wdLine If Selection Like "*" & Chr(13) = False Then .InsertAfter Chr(13) End If .MoveDown unit:=wdLine .EndKey unit:=wdLine Next .WholeStory .ConvertToTable Separator:=wdSeparateByParagraphs, NumColumns:=1, _ AutoFitBehavior:=wdAutoFitFixed Application.Run "BorderBottom" Application.Run "BorderHoriz" .HomeKey unit:=wdStory ActiveWindow.View.TableGridlines = False End With End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2004-8-28 10:29 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
很好,更简洁,但希望加入错误处理、关闭屏幕刷新(加快运行速度)和数据类型定义,这对编程过程和编程调试益处良多。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 18:05 , Processed in 0.052828 second(s), 12 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表