本例是使用DELPHI来实现VBA技术，功能包括在WORD中添加菜单及宏，然后实现套红头及清稿功能：
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls,comobj;
type
TForm1 = class(TForm)
Edit1: TEdit;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function trunc2(fval:real):integer;
var nval:integer;
begin
//进一法
if int(fval)=fval then
nval:=trunc(fval)
else
nval:=trunc(fval)+1; //整数部分+1
Result:=nval;
end;
function getWordCount(str:string):integer;
var
ncount,nzcount,necount:integer;
fecount:real;
begin
ncount:=length(WideString(str));
nzcount:=length(str)-ncount;
necount:=ncount-nzcount;
fecount:=necount/2;
nzcount:=nzcount+trunc2(fecount);
Result:=nzcount;
end;
function add_menubar(wordapp:variant):boolean; //======显示和隐藏红头的菜单、清稿的菜单及其对应的宏
var aa,bb,cc : variant;
i,j,n:integer;
bfind:boolean;
begin
try
//=====先把之前的宏清空
n := wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.CountOfLines;
If n > 0 Then
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.DeleteLines(1, n);
//=====添加显示红头的宏
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(1, 'Sub showRedHead()');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(2, ' If ActiveDocument.Bookmarks.Exists("红头") Then');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(3, ' ActiveDocument.Bookmarks.Item("红头").Range.Font.ColorIndex = wdRed');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(4, ' End If');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(5, ' If ActiveDocument.Bookmarks.Exists("五星") Then');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(6, ' ActiveDocument.Bookmarks.Item("五星").Range.Font.ColorIndex = wdRed');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(7, ' End If');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(8, ' If ActiveDocument.Bookmarks.Exists("五角星") Then');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(9, ' ActiveDocument.Bookmarks.Item("五角星").Range.Font.ColorIndex = wdRed');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(10, ' End If');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(11, ' '); //不能为空
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(12, 'Dim k As Integer');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(13, 'For k = 1 To ActiveDocument.Shapes.Count');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(14, ' If ActiveDocument.Shapes.Item(k).Type = 9 Then');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(15, ' ActiveDocument.Shapes.Item(k).Select');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(16, ' If Selection.ShapeRange.Line.ForeColor.RGB = RGB(255, 255, 255) Then');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(17, ' Selection.ShapeRange.Line.ForeColor.RGB = RGB(255, 0, 0)');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(18, ' Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 0, 0)');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(19, ' End If');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(20, ' End If');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(21, 'Next');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(22, 'End Sub ');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(23, ' ');
//=====添加隐藏红头的宏
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(24, 'Sub hideRedHead()');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(25, ' If ActiveDocument.Bookmarks.Exists("红头") Then');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(26, ' ActiveDocument.Bookmarks.Item("红头").Range.Font.ColorIndex = wdWhite');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(27, ' End If');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(28, ' If ActiveDocument.Bookmarks.Exists("五星") Then');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(29, ' ActiveDocument.Bookmarks.Item("五星").Range.Font.ColorIndex = wdWhite');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(30, ' End If');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(31, ' If ActiveDocument.Bookmarks.Exists("五角星") Then');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(32, ' ActiveDocument.Bookmarks.Item("五角星").Range.Font.ColorIndex = wdWhite');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(33, ' End If');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(34, ' ');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(35, 'Dim k As Integer');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(36, 'For k = 1 To ActiveDocument.Shapes.Count');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(37, ' If ActiveDocument.Shapes.Item(k).Type = 9 Then');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(38, ' ActiveDocument.Shapes.Item(k).Select');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(39, ' If Selection.ShapeRange.Line.ForeColor.RGB = RGB(255, 0, 0) Then');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(40, ' Selection.ShapeRange.Line.ForeColor.RGB = RGB(255, 255, 255)');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(41, ' Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(42, ' End If');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(43, ' End If');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(44, 'Next');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(45, 'End Sub ');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(46, ' ');
//=====添加接受所选修订的宏
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(47, 'Sub acceptSelectdEdit()');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(48, ' On Error Resume Next');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(49, ' WordBasic.AcceptChangesSelected');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(50, 'End Sub ');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(51, ' ');
//=====添加接受全部修订的宏
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(52, 'Sub acceptAllEdit()');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(53, ' On Error Resume Next');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(54, ' WordBasic.AcceptAllChangesInDoc');
wordapp.VBE.VBProjects.item('Normal').VBComponents.Item('ThisDocument').Codemodule.InsertLines(55, 'End Sub ');
finally
//======下面添加操作宏的菜单
try
//============================================红头与清稿工具栏=====================================================
try
bfind:=false;
for i:=1 to wordapp.CommandBars.Count do
begin
if wordapp.CommandBars.Item[i].name='红头与清稿' then
begin
//wordapp.CommandBars.Item['红头与清稿'].Delete; //若已存在,则先删除,以免重复报错
bfind:=true;
break;
end;
end;
finally
if not bfind then //不存在
wordapp.CommandBars.Add(Name:='红头与清稿').Visible := True; //新建一个栏组
end;
//============================================红头设置(&1)菜单=====================================================
try
bfind:=false;
//wordapp.CommandBars('红头与清稿').Controls('红头设置(&1)').Delete; //若已存在,则先删除,以免重复报错
for i:=1 to wordapp.CommandBars.Item['红头与清稿'].Controls.Count do
begin
if wordapp.CommandBars.Item['红头与清稿'].Controls[i].caption='红头设置(&1)' then
begin
//wordapp.CommandBars.Item['红头与清稿'].Controls['红头设置(&1)'].Delete; //若已存在,则先删除,以免重复
bfind:=true;
break;
end;
end;
finally
if not bfind then //不存在
begin
//Dim aa As CommandBarPopup
//aa:= wordapp.CommandBars('红头与清稿').Controls.Add(Type:=10,Before:=1);
aa:= wordapp.CommandBars.Item['红头与清稿'].Controls.Add(Type:=10,Before:=1); //增加菜单
aa.Caption := '红头设置(&1)';
//Dim bb As CommandBarButton
bb := aa.Controls.Add(Type:=1, Before:=1); //增加按纽
bb.Caption := '显示红头(&2)';
bb.OnAction := 'showRedHead' ; //引用宏
//Dim cc As CommandBarButton
cc := aa.Controls.Add(Type:=1, Before:=2); //增加按纽
cc.Caption := '隐藏红头(&3)' ;
cc.OnAction := 'hideRedHead' ; //引用宏
end;
end;
//============================================我要清稿(&4)菜单=====================================================
try
bfind:=false;
for i:=1 to wordapp.CommandBars.Item['红头与清稿'].Controls.Count do
begin
if wordapp.CommandBars.Item['红头与清稿'].Controls[i].caption='我要清稿(&4)' then
begin
//wordapp.CommandBars.Item['红头与清稿'].Controls['我要清稿(&4)'].Delete; //若已存在,则先删除,以免重复
bfind:=true;
break;
end;
end;
finally
if not bfind then //不存在
begin
aa:= wordapp.CommandBars.Item['红头与清稿'].Controls.Add(Type:=10,Before:=1); //增加菜单
aa.Caption := '我要清稿(&4)';
//Dim bb As CommandBarButton
bb := aa.Controls.Add(Type:=1, Before:=1); //增加按纽
bb.Caption := '接受所选修订(&5)';
bb.OnAction := 'acceptSelectdEdit' ; //引用宏
//Dim cc As CommandBarButton
cc := aa.Controls.Add(Type:=1, Before:=2); //增加按纽
cc.Caption := '接受全部修订(&6)' ;
cc.OnAction := 'acceptAllEdit' ; //引用宏
end;
end;
finally
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var fExt,sFileName:string;
msword,wpsapp:variant;
k,m,n,m_top,m_width,m_height,m_fontsize,nlen,ncount,nlinesize,nlinecount,m_height2,nmoveup,m_subject_pos:integer;
linesize,linecount:double;
tmpstr,sendunit,aa,linename:string;
begin
try
msword := CreateOleObject('word.application');
except
wpsapp := CreateOleObject('wps.application');
end;
msword.Documents.Open(FileName:=edit1.Text, ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:='',
PasswordTemplate:='', Revert:=False, WritePasswordDocument:='', WritePasswordTemplate:='', Format:=0);//Format:=wdOpenFormatAuto
sendunit:='XXX各机关单位 XXX各机关单位 XXX各机关单位 XXX各机关单位 XXX各机关单位 XXX各机关单位 XXX各机关单位 XXX各机关单位';
if msword.ActiveDocument.Bookmarks.Exists('主送') then
msword.ActiveDocument.Bookmarks.Item('主送').Range.Text:=sendunit;
if msword.ActiveDocument.Bookmarks.Exists('抄送') then
msword.ActiveDocument.Bookmarks.Item('抄送').Range.Text:=sendunit;
//=====================下面调整抄送文本框的高度========
For k:=1 to msword.ActiveDocument.Shapes.count do
begin
If msword.ActiveDocument.Shapes.item(k).type = 17 Then
begin
tmpstr := msword.ActiveDocument.Shapes.item(k).TextFrame.TextRange.Text;
If (pos('主送',tmpstr) > 0) or (pos('抄送',tmpstr)>0) or (pos('主送与抄送',tmpstr)>0) Then
begin
m_width := msword.ActiveDocument.Shapes.item(k).Width;
m_height := msword.ActiveDocument.Shapes.item(k).Height;
m_fontsize := msword.ActiveDocument.Shapes.item(k).TextFrame.TextRange.Font.Size;
//showmessage(inttostr(m_fontsize));
m_top:=msword.ActiveDocument.Shapes.item(k).Top;
//======下面是人工计算
linesize := (m_width / m_fontsize); //一行多少个字
nlinesize := trunc2(linesize);
if copy(tmpstr,length(tmpstr),1)=#10 then
tmpstr:=copy(tmpstr,0,length(tmpstr)-1); //减去换行
if copy(tmpstr,length(tmpstr),1)=#13 then
tmpstr:=copy(tmpstr,0,length(tmpstr)-1); //减去回车
nlen := getWordCount(tmpstr);
If nlen > nlinesize Then
ncount := nlen - nlinesize //除了第一行，还有多少字
Else
ncount := 0;
linecount := ncount / (nlinesize-3) ; //剩下多少行，悬挂缩进3字符
nlinecount := trunc2(linecount);
nlinecount:=nlinecount+1; //加上第一行
//=======下面是自动适应高度的方法
msword.ActiveDocument.Shapes.item(k).TextFrame.AutoSize := true;
sleep(800);//上面的自动调整需要一点时间
m_height2 :=msword.ActiveDocument.Shapes.item(k).Height;
if(m_height2-m_height<=0) and (nlinecount>1) then
begin//说明上面的自动方法不行，只好用人工计算方法
m_height2 :=trunc(30 * nlinecount+6) ; //得到文本框的高度
msword.ActiveDocument.Shapes.item(k).Height := m_height2;
end;
nmoveup := m_height2 - m_height; //移动量
msword.ActiveDocument.Shapes.item(k).Top :=m_top - nmoveup;
break;
end;
end;
end;
//=====================下面调整主题词文本框的位置========
For k:=1 to msword.ActiveDocument.Shapes.count do
begin
If msword.ActiveDocument.Shapes.item(k).type = 17 Then
begin
tmpstr := msword.ActiveDocument.Shapes.item(k).TextFrame.TextRange.Text;
If pos('主题词',tmpstr) > 0 Then
begin
m_subject_pos := msword.ActiveDocument.Shapes.item(k).Top;
msword.ActiveDocument.Shapes.item(k).Top := msword.ActiveDocument.Shapes.item(k).Top - nmoveup;
break;
end;
End;
end;
//=====================下面调整主题词下面的那条横线的位置========
m := 1000;
linename := '';
For k:=1 to msword.ActiveDocument.Shapes.count do
begin
If msword.ActiveDocument.Shapes.item(k).type = 9 Then
begin
n := msword.ActiveDocument.Shapes.item(k).Top - m_subject_pos;
If n > 0 Then
begin
If Abs(n) < m Then
begin
m := Abs(n);
linename := msword.ActiveDocument.Shapes.item(k).Name;
End;
End;
End;
end;
If linename <> '' Then
begin
msword.ActiveDocument.Shapes.item(linename).Top := msword.ActiveDocument.Shapes.item(linename).Top - nmoveup;
End;
try
add_menubar(msword);
finally
msword.ActiveWindow.ActivePane.View.Zoom.Percentage:=100; //缩放100％
msword.Visible := True;
end;
end;
end.
230
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
