word转图片delphi源代码
unit paswordtopdf; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, OleCtnrs, PDF, WinSkinData, ComCtrls, Jpeg, ImgList, ToolWin; type TFrmwordtopdf = class(TForm) PageControl1: TPageControl; TabSheet1: TTabSheet; TabSheet2: TTabSheet; TabSheet3: TTabSheet; RadioGroup1: TRadioGroup; GroupBox3: TGroupBox; TrackBar1: TTrackBar; Button2: TButton; Button3: TButton; GBPDF: TGroupBox; edtpdffileName: TEdit; btnsavepdf: TButton; gbSelectWord: TGroupBox; edtdocFilename: TEdit; btnselword: TButton; btnexit: TButton; SkinData1: TSkinData; btnreg: TButton; Button6: TButton; TabSheet4: TTabSheet; GroupBox6: TGroupBox; edtpic: TEdit; Button13: TButton; GroupBox8: TGroupBox; edtpicpdf: TEdit; Button15: TButton; Panel1: TPanel; rgpage: TRadioGroup; BitBtn1: TBitBtn; btnhelp: TBitBtn; BitBtn2: TBitBtn; lbltime: TLabel; btnWordtoPDF: TBitBtn; BitBtn7: TBitBtn; BitBtn8: TBitBtn; SetWaterMark: TBitBtn; Button1: TButton; Button4: TButton; Button5: TButton; ToolBar1: TToolBar; ImageList1: TImageList; tbWordToPDF: TToolButton; tbPPtTOPDF: TToolButton; tbPICTOPDF: TToolButton; tbSetWaterMak: TToolButton; tbAbout: TToolButton; tbHelp: TToolButton; ToolButton9: TToolButton; sbregistered: TToolButton; ToolButton11: TToolButton; ToolButton12: TToolButton; TbBuy: TToolButton; Panel2: TPanel; StatusBar1: TStatusBar; ImageList2: TImageList; pnlConvert: TPanel; Image1: TImage; lblFileName: TLabel; lblFileSize: TLabel; LbLFileType: TLabel; edtUser: TEdit; ckbopen: TCheckBox; tbMainPage: TSpeedButton; SpeedButton2: TSpeedButton; Panel4: TPanel; GroupBox4: TGroupBox; edtpptFilename: TEdit; Button8: TButton; GroupBox5: TGroupBox; edtpptpdf: TEdit; Button9: TButton; gbpptnum: TGroupBox; cbpptnum: TComboBox; Panel3: TPanel; GBRight: TGroupBox; btnConvert: TSpeedButton; Panel5: TPanel; Image2: TImage; Label1: TLabel; Panel6: TPanel; Image3: TImage; Label2: TLabel; Panel7: TPanel; Image4: TImage; Label3: TLabel; SpeedButton1: TSpeedButton; procedure btnexpClick(Sender: TObject); procedure btnselwordClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure btnsavepdfClick(Sender: TObject); procedure btnexitClick(Sender: TObject); procedure RadioGroup1Click(Sender: TObject); procedure Button2Click(Sender: TObject); procedure Button3Click(Sender: TObject); procedure TrackBar1Change(Sender: TObject); procedure Button8Click(Sender: TObject); procedure Button9Click(Sender: TObject); procedure Button13Click(Sender: TObject); procedure Button15Click(Sender: TObject); procedure btnpicpdfClick(Sender: TObject); procedure Button12Click(Sender: TObject); procedure btnregClick(Sender: TObject); procedure btnhelpClick(Sender: TObject); procedure Button14Click(Sender: TObject); procedure btnBackClick(Sender: TObject); procedure Timer1Timer(Sender: TObject); procedure btnWordtoPDFClick(Sender: TObject); procedure Image1Click(Sender: TObject); procedure lbltimeClick(Sender: TObject); procedure FormShow(Sender: TObject); procedure Button4Click(Sender: TObject); procedure tbWordToPDFClick(Sender: TObject); procedure StatusBar1DrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect); procedure Button11Click(Sender: TObject); procedure tbSetWaterMakClick(Sender: TObject); procedure tbHelpClick(Sender: TObject); procedure sbregisteredClick(Sender: TObject); procedure tbAboutClick(Sender: TObject); procedure TbBuyClick(Sender: TObject); procedure tbMainPageClick(Sender: TObject); private { Private declarations } Convertidx: integer; function setistrue(var wordFilename, pdfFileName: string): Boolean; //拷贝为图像 procedure CopyAsPicture(); //抓屏的方法 procedure scanscreen(); //获得信息 procedure GetFileInfo(FileName: string); public { Public declarations } end; var Frmwordtopdf : TFrmwordtopdf; implementation uses utMyword, utygpub, utylstream, PasERegPass, utEYLpass, utmyPPt, About, PasSetWatermark, utMyProgress, IdGlobal, utPPtToPDF; const Mycaption = 'PDFScan Converter '; Maxnum : integer = 10; function BlockInput(fFreezeInput: Boolean): DWord; stdcall; external 'user32.DLL'; {$R *.dfm} var url : string ='';// 'http://www.pdfgolds.com'; function GetFileSize(FileName: string): integer; begin result := FileSizeByName(FileName); end; function TFrmwordtopdf.setistrue(var wordFilename, pdfFileName: string): Boolean; var str : string; begin result := false; wordFilename := edtdocFilename.Text; if wordFilename = '' then begin raise exception.Create('Word doc file can''t for empty'); end; if not fileexists(wordFilename) then begin raise exception.CreateFmt('%s Document file does not exist', [wordFilename]); end; pdfFileName := edtpdffileName.Text; if pdfFileName = '' then begin raise exception.Create('pdfFiles can''t for empty'); end; str := Format('%sFile already exists, is deleted?', [pdfFileName]); if fileexists(pdfFileName) then begin if not ansker_showmessage(str, str) then exit; if not deletefile(pdfFileName) then raise exception.CreateFmt('%s Document file already exists, cannot be removed', [pdfFileName]); end; CompressionQuality := TrackBar1.Position; result := True; end; //抓屏的方法 procedure TFrmwordtopdf.scanscreen(); var MyWord : TMyWord; wordFilename, pdfFileName : string; begin if not setistrue(wordFilename, pdfFileName) then exit; MyWord := TMyWord.Create(True); BlockInput(True); self.Visible := false; try MyWord.openFile(edtdocFilename.Text); MyWord.outpdfbyScreenShot(pdfFileName); finally BlockInput(false); self.Visible := True; MyWord.Free; end; end; //拷贝为图像 procedure TFrmwordtopdf.CopyAsPicture(); var MyWord : TMyWord; wordFilename, pdfFileName : string; begin if not setistrue(wordFilename, pdfFileName) then exit; MyWord := TMyWord.Create(false); try MyWord.openFile(edtdocFilename.Text); MyWord.openPDF := self.ckbopen.Checked; MyWord.outpdfbyCopyPicture(pdfFileName); finally MyWord.Free; end; end; //获得信息 procedure TFrmwordtopdf.GetFileInfo(FileName: string); var ExtFilename : string; begin lblFileSize.Caption := 'FileSize : ' + Inttostr(GetFileSize(FileName) div 1024) + 'KB'; lblFileName.Caption := 'FileName:' + ExtractFileName(FileName); ExtFilename := uppercase(ExtractFileExt(FileName)); if ExtFilename = '.DOC' then begin LbLFileType.Caption := 'FileType: Word'; end else if ExtFilename = '.PPT' then begin LbLFileType.Caption := 'FileType: PowerPoint'; end else begin LbLFileType.Caption := 'FileType: Picture'; end; end; procedure TFrmwordtopdf.btnselwordClick(Sender: TObject); var pdfFileName : string; begin selectfile(edtdocFilename, '*.doc|*.doc'); pdfFileName := edtdocFilename.Text; edtpdffileName.Text := ChangeFileExt(pdfFileName, '.pdf'); GetFileInfo(pdfFileName); end; procedure TFrmwordtopdf.FormCreate(Sender: TObject); //判断密码是否正确 function isok(): Boolean; begin result := getisok(); sbregistered.Visible := result; TbBuy.Visible:=self.sbregistered.Visible; end; begin ylparam := 'E299'; isok(); if getisok() then begin Caption := Mycaption + ' V2.0' + getVerInfo(application.ExeName) + ' (unregistered)'; end else begin Caption := Mycaption + ' V2.0' + getVerInfo(application.ExeName); end; Convertidx := 1; self.PageControl1.ActivePageIndex := 1; end; procedure TFrmwordtopdf.FormClose(Sender: TObject; var Action: TCloseAction); begin AppSaveSet(); end; procedure TFrmwordtopdf.btnsavepdfClick(Sender: TObject); begin savefile(edtpdffileName, '*.pdf|*.pdf', '.pdf'); end; procedure TFrmwordtopdf.btnexitClick(Sender: TObject); begin close(); end; procedure TFrmwordtopdf.RadioGroup1Click(Sender: TObject); begin Convertidx := RadioGroup1.ItemIndex; end; procedure TFrmwordtopdf.Button2Click(Sender: TObject); var MyWord : TMyWord; begin CompressionQuality := 100; MyWord := TMyWord.Create(false); try MyWord.openFile(edtdocFilename.Text); //MyWord.SavePicture('c:\temp\'); MyWord.GetAllTable('c:\temp\'); finally MyWord.Free; end; end; procedure createwortoword(pdfFileName: string); var List : TstringList; i, num : integer; FileName : string; var MyWord : TMyWord; begin MyWord := TMyWord.Create(false); List := TstringList.Create; try MyWord.newDocument(); SearchTabFiles(TempPath, List, '.jpg', false); num := List.Count; //initProgressBar(num, '正在扫描'); if getisok() then begin if num > Maxnum then begin num := Maxnum; end; end; for i := 1 to num do begin FileName := TempPath + Inttostr(i) + '.jpg'; MyWord.AddPicture(FileName); MyWord.MoveEnd(); //MyWord.setbackpicture(FileName); // deletefile(pchar(FileName)); //if ProgressStep() then // Break; end; //FDoc.ActiveWindow.View.FullScreen:=True; MyWord.Save(pdfFileName); finally MyWord.Free(); List.Free(); // FreeProgressStep(); end; end; procedure TFrmwordtopdf.Button3Click(Sender: TObject); var MyWord : TMyWord; wordFilename, pdfFileName : string; begin if not setistrue(wordFilename, pdfFileName) then exit; killtask('winword.exe'); MyWord := TMyWord.Create(false); try MyWord.openFile(edtdocFilename.Text); MyWord.outjpgbyCopyPicture(pdfFileName); finally MyWord.Free; end; //createwortoword('c:\1.doc'); end; procedure TFrmwordtopdf.TrackBar1Change(Sender: TObject); begin GroupBox3.Caption := Format('Export pictures PDF quality(%d', [TrackBar1.Position]) + '%)'; end; procedure TFrmwordtopdf.Button8Click(Sender: TObject); var pdfFileName : string; begin selectfile(edtpptFilename, '*.ppt|*.ppt'); pdfFileName := edtpptFilename.Text; edtpptpdf.Text := ChangeFileExt(pdfFileName, '.pdf'); GetFileInfo(pdfFileName); end; procedure TFrmwordtopdf.Button9Click(Sender: TObject); begin savefile(edtpptpdf, '*.pdf|*.pdf', '.pdf'); end; procedure TFrmwordtopdf.Button13Click(Sender: TObject); var pdfFileName : string; begin selectfile(edtpic, '*.jpg|*.jpg|*.bmp|*.bmp|*.wmf|*.wmf|*.emf|*.emf'); pdfFileName := edtpic.Text; GetFileInfo(pdfFileName); edtpicpdf.Text := ChangeFileExt(pdfFileName, '.pdf'); end; procedure TFrmwordtopdf.Button15Click(Sender: TObject); begin savefile(edtpicpdf, '*.pdf|*.pdf', '.pdf'); end; procedure TFrmwordtopdf.btnpicpdfClick(Sender: TObject); function picsetistrue(var wordFilename, pdfFileName: string): Boolean; var str : string; begin result := false; wordFilename := edtpic.Text; if wordFilename = '' then begin raise exception.Create('Picture files can''t for empty'); end; if not fileexists(wordFilename) then begin raise exception.CreateFmt('%sPicture file does not exist', [wordFilename]); end; pdfFileName := edtpicpdf.Text; if pdfFileName = '' then begin raise exception.Create('pdfFiles can''t for empty'); end; str := Format('%s File already exists, is deleted?', [pdfFileName]); if fileexists(pdfFileName) then begin if not ansker_showmessage(str, str) then exit; if not deletefile(pdfFileName) then raise exception.CreateFmt('%sDocument file already exists, cannot be removed!', [pdfFileName]); end; CompressionQuality := TrackBar1.Position; result := True; end; var pdfFileName, wordFilename : string; idx : integer; begin if not picsetistrue(wordFilename, pdfFileName) then exit; //btnpicpdf.Enabled := false; try idx := rgpage.ItemIndex; onePICTOPDF(idx, wordFilename, pdfFileName); finally //btnpicpdf.Enabled := True; end; end; procedure TFrmwordtopdf.Button12Click(Sender: TObject); begin self.PageControl1.ActivePageIndex := 0; end; procedure TFrmwordtopdf.btnregClick(Sender: TObject); var FrmRegPass : TFrmRegPass; begin FrmRegPass := TFrmRegPass.Create(nil); self.btnreg.Visible := not (FrmRegPass.showmodal = mrok); if not self.btnreg.Visible then begin end; FrmRegPass.Free; end; procedure TFrmwordtopdf.btnhelpClick(Sender: TObject); begin //runfile(ChangeFileExt(application.ExeName, '.chm'), 'open'); runfile(url, ''); end; procedure TFrmwordtopdf.Button14Click(Sender: TObject); begin self.PageControl1.ActivePageIndex := 0; end; procedure TFrmwordtopdf.btnBackClick(Sender: TObject); begin self.PageControl1.ActivePageIndex := 0; end; procedure TFrmwordtopdf.Timer1Timer(Sender: TObject); begin if (lbltime.Font.Color = clwhite) then begin lbltime.Font.Color := clred; end else begin lbltime.Font.Color := clwhite; end; end; procedure TFrmwordtopdf.btnWordtoPDFClick(Sender: TObject); var tag : integer; begin tag := (Sender as TBitBtn).tag; self.PageControl1.ActivePageIndex := tag; //scaleZoom:=StrTofloat(edit1.Text); end; procedure TFrmwordtopdf.Image1Click(Sender: TObject); begin runfile(url, ''); end; procedure TFrmwordtopdf.lbltimeClick(Sender: TObject); begin runfile(url, ''); end; procedure TFrmwordtopdf.FormShow(Sender: TObject); function GetmyComputerName(): string; var ComputerName : array[0..MAX_COMPUTERNAME_LENGTH + 1] of char; sComputerName : string; lpSize : DWord; begin lpSize := MAX_COMPUTERNAME_LENGTH + 1; if GetComputerName(@ComputerName, lpSize) then begin sComputerName := ComputerName; end else begin sComputerName := ''; end; // Result := sResult ; result := sComputerName; end; begin AppgetSet(); edtUser.Text := GetmyComputerName(); TempPath := GetTemPath() + 'gisoracle\'; //showmessage(TempPath); end; procedure TFrmwordtopdf.Button4Click(Sender: TObject); begin showmessage(GetWindowsVersion()); end; procedure TFrmwordtopdf.tbWordToPDFClick(Sender: TObject); var tag : integer; begin tag := (Sender as TToolButton).tag; self.PageControl1.ActivePageIndex := tag; GBRight.Parent := self.PageControl1.Pages[tag]; //scaleZoom:=StrTofloat(edit1.Text); end; {var progressBarRect : TRect; // 进度条组件的尺寸} procedure TFrmwordtopdf.StatusBar1DrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect); begin // progressBarRect := Rect; utMyProgress.progressBarRect := Rect; utMyProgress.StatusBar1 := StatusBar1; end; procedure TFrmwordtopdf.Button11Click(Sender: TObject); var i : integer; begin utMyProgress.initProgressBar(10000); for i := 1 to 10000 do begin utMyProgress.ProgressStep() end; MessageDlg('演示操作已经完成!', mtInformation, [mbOK], 0); utMyProgress.FreeProgressStep(); end; procedure TFrmwordtopdf.tbSetWaterMakClick(Sender: TObject); begin FrmSetWaterMark.Show(); end; procedure TFrmwordtopdf.tbHelpClick(Sender: TObject); begin // //runfile('http://www.pdfgolds.com/help', ''); runfile('',''); end; procedure TFrmwordtopdf.sbregisteredClick(Sender: TObject); var FrmRegPass : TFrmRegPass; begin FrmRegPass := TFrmRegPass.Create(nil); self.sbregistered.Visible := not (FrmRegPass.showmodal = mrok); TbBuy.Visible:=self.sbregistered.Visible; if not self.btnreg.Visible then begin end; FrmRegPass.Free; end; procedure TFrmwordtopdf.tbAboutClick(Sender: TObject); var FrmAboutBox : TFrmAboutBox; begin FrmAboutBox := TFrmAboutBox.Create(nil); FrmAboutBox.showmodal; FrmAboutBox.Free; end; procedure TFrmwordtopdf.TbBuyClick(Sender: TObject); var str : string; begin str := 'http://www.pdfgolds.com/register.html'; str:=''; runfile(str, ''); end; procedure TFrmwordtopdf.btnexpClick(Sender: TObject); procedure Runword(); begin if exe_is_running('winword.exe') then begin showmessage('Word Has been in operation, please Save yourself files, shut down word'); end; if exe_is_running('winword.exe') then begin if not ansker_showmessage('Word has been in operation, whether to need to program management closed word', 'Word has been in operation, whether to need to program management closed word') then exit; killtask('winword.exe'); end; if Convertidx = 0 then begin scanscreen(); end else if Convertidx = 1 then //使用这种方式转换 begin CopyAsPicture(); end; end; procedure PPTTOPDF(); function pptsetistrue(var wordFilename, pdfFileName: string): Boolean; var str : string; begin result := false; wordFilename := edtpptFilename.Text; if wordFilename = '' then begin raise exception.Create('PPT Files can''t for empty'); end; if not fileexists(wordFilename) then begin raise exception.CreateFmt('%s Document file does not exist', [wordFilename]); end; pdfFileName := edtpptpdf.Text; if pdfFileName = '' then begin raise exception.Create('pdf Files can''t for empty'); end; str := Format('%sFile already exists, Is deleted?', [pdfFileName]); if fileexists(pdfFileName) then begin if not ansker_showmessage(str, str) then exit; if not deletefile(pdfFileName) then raise exception.CreateFmt('%s Document file already exists, cannot be removed', [pdfFileName]); end; CompressionQuality := TrackBar1.Position; result := True; end; var myPowerPoint : TmyPowerPoint; wordFilename, pdfFileName : string; pptnum, w, h : integer; begin if not pptsetistrue(wordFilename, pdfFileName) then exit; pptnum := strtointdef(cbpptnum.Text, 1); //btnexpppt.Enabled := false; try myPowerPoint := TmyPowerPoint.Create(false); //myPowerPoint.ConvertAllPagesToJpg(wordFilename); getimgwh(pptnum, w, h); //showmessage('ok====111=='); myPowerPoint.ConvertAllOnetoOnePagesToJpg(wordFilename, w, h); //showmessage('ok======222===='); myPowerPoint.Free(); //showmessage('ok'); createppttopdf(pdfFileName, pptnum, w, h); //DeleteTempFolder(getapppath() + 'img\'); finally //btnexpppt.Enabled := True; end; end; var idx : integer; begin self.StatusBar1.Panels[1].Text := ''; openPDF := self.ckbopen.Checked; btnConvert.Enabled := false; try DeleteTempFolder(TempPath); idx := PageControl1.ActivePageIndex; if idx = 1 then begin Runword(); end else if idx = 2 then //PPt转PDF begin PPTTOPDF(); end else begin btnpicpdfClick(nil); end; finally btnConvert.Enabled := True; //RemoveDir(getapppath() + 'img\'); DeleteTempFolder(TempPath); end; end; procedure TFrmwordtopdf.tbMainPageClick(Sender: TObject); begin runfile(url, ''); end; end.
word操作
unit utMyword; (* By 闫磊 编写 2004.09.06 Email:landgis@126.com yanleigis@21cn.com *) interface uses Word_TLB, ActiveX, Variants, Dialogs, SysUtils, Forms, Classes, Clipbrd; type TMyWord = class(TObject) protected FWord: TWordApplication; //word对象 FDoc: WordDocument; //文档对象 procedure connectword(Visible: boolean); public openPDF: boolean; //换行 procedure AddReturn(); //设置字体 procedure SetFont(FontName: string; FontSize: integer; FontBold: boolean = false; FontUnderline: boolean = false); //插入表格 function AddTable(Col, Row: integer): Table; //设置背景色 procedure SetTableBack(BackColor: ToleEnum); //鼠标下移 procedure MoveDown(num: integer = 1); //选择下移 procedure SelectDown(num: integer = 1); //鼠标上移 procedure Moveup(); //鼠标右移 procedure MoveRight(num: integer = 1); //选择右移 procedure SelectRight(num: integer = 1); //写字 procedure WriteText(Text: string); //按样式插入一行记录 //如AddLine "备注","正文" //AddLine 'kk',"标题 1" procedure AddLine(S: string; PStyle: olevariant); procedure AlignLine(Align: ToleEnum); //插入分页符 procedure insertPage(OleEnum: ToleEnum); //输出pdf,靠抓屏 procedure outpdfbyScreenShot(pdfFileName: string); //输出pdf,靠拷贝picture procedure outpdfbyCopyPicture(pdfFileName: string); //输出jpg,word,靠拷贝picture procedure outjpgbyCopyPicture(wordfilename: string); //输出jpg procedure outjpg(wordfile, path, ptype: string); //插入插入页码 procedure insertPagenum(); //插入日期 procedure insertDate(); //设置表格一列宽度 procedure SetTable(PTable: Table; ColumnIdx: integer; Width: integer); //设置表格一列高度 procedure SetTableheight(PTable: Table; RowIdx: integer; height: integer); //创立书签 procedure createBookMark(BookMarkName: string); //移动到标签 procedure GotoBookMark(BookMarkName: string); //粘贴 procedure paste(); //拷贝 procedure copy(); //拷贝 procedure copyaspicture(FileName: string; var w, h: integer); overload; procedure copyaspicture(FileName: string); overload; //自动大小 //替换 procedure Replace(Source, Target: string); //保存 procedure Save(FileName: string); overload; procedure Save(FFdoc: WordDocument; FileName: string); overload; procedure openFile(FileName: string; myReadonly: boolean = True); //提取所有图片 到指定目录 procedure SavePicture(dir: string); //插入图片 procedure AddPicture(FileName: string); overload; procedure AddPicture(FileName: string; FFdoc: WordDocument); overload; //移到最后 procedure MoveEnd(); //移到最前面 procedure MoveFirst(); //合并 procedure CellsMerge(); constructor Create(Visible: boolean); destructor Destroy; override; //到第几页并选择 procedure gotopage(pagenum: integer; var pagew, pageH, pleft, ptop, pright, pbottom: single; var isLand: boolean); //获得纸张的宽度和高度,isLand为true横向 function newDocument(): WordDocument; //获得所有的表格 procedure GetAllTable(dir: string); //何把WORD编号转换为普通文本? procedure AutonumTotext(); procedure getpageinfo(r: Range; var pagew, pageH, pleft, ptop, pright, pbottom: single; var isLand: boolean); //获得当前节数 function GetSectionNumber(): integer; //是否保存关闭 procedure close(Saveed: boolean); end; var CompressionQuality : integer; Maxnum : integer = 200; htmlPage : boolean = false; scaleZoom : double = 0.8; implementation uses Windows, Graphics, Jpeg, utygpub, pdf, utMyProgress, utEYLpass, utWaterMarkParam, utPPtToPDF; const scalenum = 1; var gisoracle : string; constructor TMyWord.Create(Visible: boolean); begin inherited Create; gisoracle := 'unregistered'; connectword(Visible); // end; procedure TMyWord.connectword(Visible: boolean); var B : boolean; begin B := false; if (FWord = nil) then B := True else begin try FDoc.Activate; except B := True; end; end; if not B then exit; FWord := TWordApplication.Create(nil); //word对象 try FWord.Connect; except showmessage('No installation word or install word version is wrong'); end; FWord.Visible := Visible; end; destructor TMyWord.Destroy; begin // //FDoc.SaveAs('c:\1.doc'); //FDoc.Free; FWord.Disconnect; //退出一定退出word,by yl 2005.2.2 FWord.Quit; FWord.Free; inherited Destroy; end; procedure TMyWord.AddReturn(); begin try FWord.Selection.TypeParagraph; except AddReturn(); end; end; procedure TMyWord.SetFont(FontName: string; FontSize: integer; FontBold: boolean = false; FontUnderline: boolean = false); begin try //connectword(); FWord.Selection.Font.Name := FontName; FWord.Selection.Font.Size := FontSize; if FontBold then FWord.Selection.Font.Bold := wdToggle; if FontUnderline then FWord.Selection.Font.Underline := wdUnderlineSingle; except SetFont(FontName, FontSize, FontBold, FontUnderline); end; end; //插入表格 function TMyWord.AddTable(Col, Row: integer): Table; var DefaultTable : olevariant; begin try //connectword(); DefaultTable := 1; result := FDoc.Tables.Add(FWord.Selection.Range, Row, Col, DefaultTable, EmptyParam); except showmessage(Format('Col%d,row%d', [Col, Row])); AddTable(Col, Row); end; end; //设置背景色 procedure TMyWord.SetTableBack(BackColor: ToleEnum); begin try //connectword(); FWord.Selection.Cells.Shading.BackgroundPatternColor := BackColor; except SetTableBack(BackColor); end; end; //选择下移 procedure TMyWord.SelectDown(num: integer = 1); var Unit_ : olevariant; Count : olevariant; Extend : olevariant; begin try //connectword(); Count := num; Unit_ := wdLine; Extend := wdExtend; FWord.Selection.MoveDown(Unit_, Count, Extend); except MoveDown(); end; end; //鼠标下移 procedure TMyWord.MoveDown(num: integer = 1); var Unit_ : olevariant; Count : olevariant; Extend : olevariant; begin try //connectword(); Count := num; Unit_ := wdLine; FWord.Selection.MoveDown(Unit_, Count, Extend); except MoveDown(); end; end; //鼠标上移 procedure TMyWord.Moveup(); var Unit_ : olevariant; Count : olevariant; Extend : olevariant; begin Unit_ := wdLine; Count := 1; FWord.Selection.Moveup(Unit_, Count, Extend); end; //选择右移 procedure TMyWord.SelectRight(num: integer = 1); var Unit_ : olevariant; Count : olevariant; Extend : olevariant; begin try //connectword(); Unit_ := wdCharacter; Count := num; Extend := wdExtend; FWord.Selection.MoveRight(Unit_, Count, Extend); except MoveRight(); end; end; //鼠标右移 procedure TMyWord.MoveRight(num: integer = 1); var Unit_ : olevariant; Count : olevariant; Extend : olevariant; begin try //connectword(); Unit_ := wdCell; Count := num; FWord.Selection.MoveRight(Unit_, Count, Extend); except MoveRight(); end; end; //写字 procedure TMyWord.WriteText(Text: string); begin try //connectword(); FWord.Selection.TypeText(Text); except //防止呼叫失败 WriteText(Text); end; end; //按样式插入一行记录 //如AddLine "备注","正文" //AddLine 'kk',"标题 1" procedure TMyWord.AddLine(S: string; PStyle: olevariant); procedure SetStyle(PStyle: olevariant); var outStyle : Style; v : olevariant; begin outStyle := FWord.ActiveDocument.Styles.Item(PStyle); v := outStyle; FWord.Selection.Set_Style(v); end; begin WriteText(S); //加入一行 try SetStyle(PStyle); except SetStyle(PStyle); end; end; procedure TMyWord.AlignLine(Align: ToleEnum); begin FWord.Selection.ParagraphFormat.Alignment := Align; end; //插入分页符 procedure TMyWord.insertPage(OleEnum: ToleEnum); var _Type : olevariant; begin _Type := OleEnum; // FWord.Selection.InsertBreak(_Type); end; //插入日期 procedure TMyWord.insertDate(); var DateTimeFormat : olevariant; InsertAsField : olevariant; InsertAsFullWidth : olevariant; DateLanguage : olevariant; CalendarType : olevariant; begin try InsertAsField := false; InsertAsFullWidth := false; DateTimeFormat := 'yyyy''year''M''month''d''day'''; DateLanguage := wdSimplifiedChinese; CalendarType := wdCalendarWestern; FWord.Selection.InsertDateTime(DateTimeFormat, InsertAsField, InsertAsFullWidth, DateLanguage, CalendarType); except insertDate(); end; end; //插入页码 procedure TMyWord.insertPagenum(); var PSection : Section; PageNumberAlignment : olevariant; FirstPage : olevariant; begin PSection := FWord.Selection.Sections.Item(1); PageNumberAlignment := 1; //中间 FirstPage := True; PSection.Footers.Item(wdHeaderFooterPrimary).PageNumbers.Add(PageNumberAlignment, FirstPage); end; //设置表格一列高度 procedure TMyWord.SetTableheight(PTable: Table; RowIdx: integer; height: integer); var Prow : Row; begin Prow := PTable.Rows.Item(RowIdx); Prow.SetHeight(height, wdAdjustNone); end; //设置表格一列宽度 procedure TMyWord.SetTable(PTable: Table; ColumnIdx: integer; Width: integer); begin PTable.Columns.Item(ColumnIdx).SetWidth(Width, wdAdjustNone); end; //创立书签 procedure TMyWord.createBookMark(BookMarkName: string); var pRange : olevariant; begin pRange := FWord.Selection.Range; with FWord.ActiveDocument.Bookmarks do begin Add(BookMarkName, pRange); DefaultSorting := wdSortByName; ShowHidden := false; end; end; //移动到标签 procedure TMyWord.GotoBookMark(BookMarkName: string); var What : olevariant; Which : olevariant; Count : olevariant; Name : olevariant; begin What := wdGoToBookmark; Name := 'BEGIN'; FWord.Selection.GoTo_(What, Which, Count, Name) end; //粘贴 procedure TMyWord.paste(); begin FWord.Selection.paste; end; //拷贝 procedure TMyWord.copy(); begin FWord.Selection.WholeStory(); FWord.Selection.copyaspicture(); end; //到第几页并选择,旧的方法 {procedure TMyWord.gotopage(pagenum: Integer; var pagew, pageH, pleft, ptop, pright, pbottom: single; var isLand: Boolean); var What, Which, Name, wForward, Wrap, MatchByte: olevariant; wUnit, Extend : olevariant; begin What := wdGoToPage; Which := wdGoToNext; Name := Format('%d', [pagenum]); FWord.Selection.GoTo_(What, Which, EmptyParam, Name); FWord.Selection.Find.ClearFormatting(); wForward := True; Wrap := wdFindcontinue; MatchByte := True; FWord.Selection.Find.Execute(EmptyParam, MatchByte, EmptyParam, EmptyParam, EmptyParam, EmptyParam, wForward, Wrap, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam); wUnit := wdStory; Extend := wdExtend; FWord.Selection.EndKey(wUnit, Extend); application.ProcessMessages(); getpageinfo(FWord.Selection.Range, pagew, pageH, pleft, ptop, pright, pbottom, isLand); FWord.Selection.copyaspicture(); end; } procedure TMyWord.getpageinfo(r: Range; var pagew, pageH, pleft, ptop, pright, pbottom: single; var isLand: boolean); begin with r.Sections.Item(1).PageSetup do begin pagew := PageWidth; pageH := PageHeight; pleft := LeftMargin; // '左页边距 ptop := TopMargin; //'上边距 pright := RightMargin; // '左页边距 pbottom := BottomMargin; //'上边距 isLand := Orientation = wdOrientLandscape; end; end; //到第几页并选择,新的的方法,跨页的表格选不上,修改选择文档未 procedure TMyWord.gotopage(pagenum: integer; var pagew, pageH, pleft, ptop, pright, pbottom: single; var isLand: boolean); var What, Which, Name : olevariant; r1start, r2start : olevariant; r1, r2 : Range; //Pageinfo : olevariant; begin if (pagenum = 1) then // 首页可能从0开始 begin What := wdGoToSection; Which := wdGoToFirst; r1 := FDoc.GoTo_(What, Which, EmptyParam, EmptyParam); end else begin What := wdGoToPage; Which := wdGoToAbsolute; Name := Format('%d', [pagenum]); r1 := FDoc.GoTo_(What, Which, EmptyParam, Name); end; r2 := r1.GoToNext(What); //页末 r2start := FDoc.Sections.Item(r1.Sections.Last.Index).Range.End_; //一节的结束 if htmlPage then begin if (r2.Start > r2start) or (pagenum > 1) then begin r2start := r2.Start; end; end else begin if (r2.Start > r2start) then begin r2start := r2.Start; end; end; r1start := r1.Start; //ShowMessage(Format('pagenum=%d,Sectnum=%d,r1start=', [pagenum, Sectnum])+ // inttostr(r1start) + ',r2start+' + inttostr(r2start)); getpageinfo(r1, pagew, pageH, pleft, ptop, pright, pbottom, isLand); if r2start > r1start then begin FDoc.Range(r1start, r2start).copyaspicture(); //复制到剪贴板,拷贝copys copyaspicture() 一样的 end; end; {//到第几页并选择,新的的方法,跨页的表格选不上 procedure TMyWord.gotopage(pagenum: Integer; var pagew, pageH, pleft, ptop, pright, pbottom: single; var isLand: Boolean); var What, Which, Name : olevariant; r1start, r2start : olevariant; r1, r2 : Range; begin What := wdGoToPage; Which := wdGoToAbsolute; Name := Format('%d', [pagenum]); r1 := FDoc.GoTo_(What, Which, EmptyParam, Name); r2 := r1.GoToNext(What); if r1.start = r2.start then //假如这一页是最后一页了,那么要这样处理一下 begin r2.start := FDoc.Content.End_; //整个文档的结束 end else begin r2.start := r2.start + 150; end; r2start := r2.start; r1start := r1.start; getpageinfo(r1,pagew, pageH, pleft, ptop,pright, pbottom,isLand); FDoc.Range(r1start, r2start).copyaspicture(); //复制到剪贴板,拷贝copys copyaspicture() 一样的 end; } {//到第几页并选择,新的的方法,跨页的表格选不上,修改选择文档未 procedure TMyWord.gotopage(pagenum: integer; var pagew, pageH, pleft, ptop, pright, pbottom: single; var isLand: boolean); var What, Which, Name : olevariant; r1start, r2start : olevariant; r1, r2 : Range; //Pageinfo : olevariant; begin What := wdGoToPage; Which := wdGoToAbsolute; Name := Format('%d', [pagenum]); r1 := FDoc.GoTo_(What, Which, EmptyParam, Name); r2 := r1.GoToNext(What); //页末 r2start := FDoc.Sections.Item(r1.Sections.Last.Index).Range.End_; //一节的结束 if htmlPage then begin if (r2.Start > r2start) or (pagenum > 1) then begin r2start := r2.Start; end; r1start := r1.Start; //ShowMessage(Format('pagenum=%d,Sectnum=%d,r1start=', [pagenum, Sectnum])+ // inttostr(r1start) + ',r2start+' + inttostr(r2start)); getpageinfo(r1, pagew, pageH, pleft, ptop, pright, pbottom, isLand); if r2start > r1start then begin FDoc.Range(r1start, r2start).copyaspicture(); //复制到剪贴板,拷贝copys copyaspicture() 一样的 end; end else begin if (r2.Start > r2start) then begin r2start := r2.Start; end; r1start := r1.Start; getpageinfo(r1, pagew, pageH, pleft, ptop, pright, pbottom, isLand); FDoc.Range(r1start, r2start).copyaspicture(); //复制到剪贴板,拷贝copys copyaspicture() 一样的 end; end; } //替换 procedure TMyWord.Replace(Source, Target: string); var FindText : olevariant; PWrap : olevariant; ReplaceWith : olevariant; Replace : olevariant; begin FWord.Selection.Find.ClearFormatting; FWord.Selection.Find.Replacement.ClearFormatting; FindText := Source; PWrap := wdFindcontinue; ReplaceWith := Target; Replace := wdReplaceAll; with FWord.Selection.Find do begin Execute(FindText, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, PWrap, EmptyParam, ReplaceWith, Replace, EmptyParam, EmptyParam, EmptyParam, EmptyParam); end; end; //保存 procedure TMyWord.Save(FileName: string); begin if FileName = '' then begin FDoc.Save(); exit; end; Save(FDoc, FileName); end; procedure TMyWord.Save(FFdoc: WordDocument; FileName: string); var OFilename : olevariant; begin FFdoc.Activate(); OFilename := FileName; FFdoc.SaveAs(OFilename, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam); end; procedure TMyWord.openFile(FileName: string; myReadonly: boolean = True); var OFilename, ConfirmConversions, AddToRecentFiles, ReadOnly, PassWordDocument, PasswordTemplate, Revent, WritePasswordDocument, WritePassWordTemplate, Format, Encoding, Visible : olevariant; begin OFilename := FileName; ConfirmConversions := false; ReadOnly := myReadonly; AddToRecentFiles := false; PassWordDocument := EmptyParam; PasswordTemplate := EmptyParam; Revent := True; WritePasswordDocument := EmptyParam; WritePassWordTemplate := EmptyParam; Format := wdopenformatauto; Encoding := EmptyParam; Visible := True; FDoc := FWord.Documents.Open(OFilename, ConfirmConversions, ReadOnly, AddToRecentFiles, PassWordDocument, PasswordTemplate, Revent, WritePasswordDocument, WritePassWordTemplate, Format, Encoding, Visible, EmptyParam, EmptyParam, EmptyParam, EmptyParam); Application.ProcessMessages(); end; //插入图片 procedure TMyWord.AddPicture(FileName: string); var LinkToFile, SaveWithDocument, Range : olevariant; //index: olevariant; begin //index := 0; //Range := FDoc.Bookmarks.Item(index).Range; //Range:=Fdoc.GoTo_; Range := self.FWord.Selection.Range; LinkToFile := false; SaveWithDocument := True; FWord.Selection.InlineShapes.AddPicture(FileName, LinkToFile, SaveWithDocument, Range) end; procedure TMyWord.AddPicture(FileName: string; FFdoc: WordDocument); var LinkToFile, SaveWithDocument, Range : olevariant; //index: olevariant; begin //index := 0; //Range := FDoc.Bookmarks.Item(index).Range; FFdoc.Activate(); Range := self.FWord.Selection.Range; LinkToFile := false; SaveWithDocument := True; FFdoc.InlineShapes.AddPicture(FileName, LinkToFile, SaveWithDocument, Range); end; //移到最后 procedure TMyWord.MoveEnd(); var Unit_ : olevariant; Extend : olevariant; begin Unit_ := wdStory; Extend := wdMove; FWord.Selection.EndKey(Unit_, Extend); end; //移到最前面 procedure TMyWord.MoveFirst(); var Unit_ : olevariant; Extend : olevariant; begin Unit_ := wdStory; Extend := wdMove; FWord.Selection.HomeKey(Unit_, Extend); end; //合并 procedure TMyWord.CellsMerge(); begin FWord.Selection.Cells.Merge; end; //抓屏函数 procedure ScreenShot(x: integer; y: integer; Width: integer; height: integer; bm: TBitMap); overload; var dc : HDC; lpPal: PLOGPALETTE; begin // 检测所需抓屏的区域 if ((Width = 0) or (height = 0)) then exit; bm.Width := Width; bm.height := height; //获取设备上下文 dc := GetDc(0); if (dc = 0) then exit; {do we have a palette device?} if (GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE) then begin {allocate memory for a logical palette} GetMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY))); {zero it out to be neat} FillChar(lpPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0); {fill in the palette version} lpPal^.palVersion := $300; {grab the system palette entries} lpPal^.palNumEntries := GetSystemPaletteEntries(dc, 0, 256, lpPal^.palPalEntry); if (lpPal^.palNumEntries <> 0) then begin {create the palette} bm.Palette := CreatePalette(lpPal^); end; FreeMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY))); end; {copy from the screen to the bitmap} BitBlt(bm.Canvas.Handle, 0, 0, Width, height, dc, x, y, SRCCOPY); {release the screen dc} ReleaseDc(0, dc); end; //Canvas:目标;Text:文字;X,Y:输出坐标;Angle:旋转角度(角度制) procedure AngleTextOut(Canvas: TCanvas; Text: string; x, y, Angle: integer); var NewFnt, OldFnt : TFont; Lfnt : TLogFont; begin NewFnt := TFont.Create; NewFnt.Assign(Canvas.Font); GetObject(NewFnt.Handle, sizeof(Lfnt), @Lfnt); with Lfnt do begin lfEscapement := 10 * Angle; lfOrientation := 0; //lfOutPrecision := OUT_DEFAULT_PRECIS or OUT_TT_ONLY_PRECIS; end; NewFnt.Handle := CreateFontIndirect(Lfnt); OldFnt := TFont.Create; OldFnt.Assign(Canvas.Font); Canvas.Font.Assign(NewFnt); NewFnt.Free; Canvas.Brush.Style := bsClear; Canvas.TextOut(x, y, Text); Canvas.Font.Assign(OldFnt); OldFnt.Free; end; procedure savejpg(bmp: TBitMap; FileName: string; FontSize: integer); const qqstr : string = 'QQ:276529800'; infostr : string = '';//support@pdfgolds.com '; var jpg : tjpegimage; ext : string; begin bmp.Transparent := True; bmp.Canvas.Font.Color := Clred; bmp.Canvas.Font.Name := 'MS Sans Serif'; bmp.Canvas.Font.Size := FontSize; {if getisok() then begin AngleTextOut(bmp.Canvas, infostr + 'unregistered', 50, 200, -10); AngleTextOut(bmp.Canvas, qqstr, 50, 300, -10); end;} ext := uppercase(ExtractFileExt(FileName)); if ext = '.BMP' then begin bmp.SaveToFile(FileName); end else begin jpg := tjpegimage.Create; try jpg.Assign(bmp); jpg.CompressionQuality := CompressionQuality; jpg.Compress; jpg.SaveToFile(FileName); finally jpg.Free(); end; end; end; //抓屏函数 procedure ScreenShot(x: integer; y: integer; Width: integer; height: integer; FileName: string); overload; var bmp : TBitMap; begin bmp := TBitMap.Create; try ScreenShot(x, y, Width, height, bmp); savejpg(bmp, FileName, 10); finally bmp.Free(); end; end; //抓屏函数 procedure ScreenShot(FileName: string; var imgw, imgh: integer); overload; const wd = 460; var w, h : integer; begin w := Screen.Width; h := Screen.height; w := (w - wd) div 2; imgw := wd; imgh := h - 40 - 85; ScreenShot(w, 85, wd, imgh, FileName); end; procedure TMyWord.copyaspicture(FileName: string); //自动大小 var Img : TMetaFile; bmp : TBitMap; w, h : integer; ext : string; begin Img := TMetaFile.Create; Img.Assign(ClipBoard); ext := uppercase(ExtractFileExt(FileName)); if ext = '.EMF' then begin Img.SaveToFile(FileName); end else begin bmp := TBitMap.Create; try w := Img.Width; h := Img.height; bmp.Width := w; bmp.height := h; //Bmp.PixelFormat := pfDevice; bmp.Canvas.Draw(0, 0, Img); savejpg(bmp, FileName, 10); finally bmp.Free(); end; end; Img.Free; end; procedure TMyWord.copyaspicture(FileName: string; var w, h: integer); const zoom = 0.8; // : double = 0.34; var Img : TMetaFile; bmp : TBitMap; imgw, imgh : integer; begin Img := TMetaFile.Create; Img.Assign(ClipBoard); imgw := trunc(Img.Width * scaleZoom); imgh := trunc(Img.height * scaleZoom); { if (imgw > w) then begin imgw := w; end; if (imgh > h) then begin imgh := h; end; } Img.Width := imgw; Img.height := imgh; bmp := TBitMap.Create; try w := Img.Width; h := Img.height; bmp.Width := w; bmp.height := h; //Bmp.PixelFormat := pfDevice; bmp.Canvas.Draw(0, 0, Img); savejpg(bmp, FileName, 10); finally bmp.Free(); end; Img.Free; end; var MyPDF : TPDFDocument; procedure Createpdf(pdfFileName: string); begin MyPDF.FileName := pdfFileName; MyPDF.Compression := ctNone; MyPDF.ProtectionEnabled := false; MyPDF.OwnerPassword := gisoracle; MyPDF.PageMode := pmUseOutlines; MyPDF.PageLayout := plSinglePage; //MyPDF.AutoLaunch := True; MyPDF.NonEmbeddedFont.Add('Impact'); MyPDF.BeginDoc; end; procedure writerightinfo(i: integer); begin ReadSetInfo(); //showmessage('ok============='); if not getisok() then begin //showmessage('ok'); if trim(WaterMarkParamstr) <> '' then begin //showmessage('ok1'); with MyPDF.CurrentPage do begin SetActiveFont(WatermarkFont.Name, [fsBold], WatermarkFont.Size); SetTextRenderingMode(2); SetRGBColorFill(getRvalue(WatermarkFont.Color), getGvalue(WatermarkFont.Color), getBvalue(WatermarkFont.Color)); SetRGBColorStroke(Random(256) / 256, Random(256) / 256, Random(256) / 256); TextOut(Width / 2 - offset, height / 2 - abs(offset), FontAngle, WaterMarkParamstr); //showmessage(WaterMarkParamstr); end; end; exit; end; with MyPDF.CurrentPage do begin SetActiveFont('Times', [fsBold], 25); SetTextRenderingMode(2); SetRGBColorFill(Random(256) / 256, Random(256) / 256, Random(256) / 256); SetRGBColorStroke(Random(256) / 256, Random(256) / 256, Random(256) / 256); TextOut(Width / 2, 550, i * 10, gisoracle); end; end; procedure writepdfpagebottom(); var Ur : TPDFURLAction; i : integer; begin if not getisok() then exit; Ur := TPDFURLAction(MyPDF.CreateAction(TPDFURLAction)); Ur.URL :='http://www.cnblogs.com/gisoracle/'; for i := 1 to MyPDF.PageCount - 1 do with MyPDF[i] do begin SetLineWidth(2); // BeginText; SetRGBColor(0.5, 0.5, 0.5); SetTextRenderingMode(0); SetActiveFont('Times', [fsBold], 12); TextOut(Width - 5 - GetTextWidth(inttostr(i + 1)), height - 17, 0, inttostr(i + 1)); SetActiveFont('Times', [fsBold, fsItalic], 10); TextOut(5, height - 15, 0,''); // 'http://www.pdfgolds.com/'); SetAction(Rect(5, height - 15, round(GetTextWidth('http://www.pdfgolds.com/')) + 5, height), Ur); TextOut(200, height - 15, 0, ''); // 'email:Support@pdfgolds.com '); // EndText; NewPath; MoveTo(5, height - 15); LineTo(Width - 5, height - 15); Stroke; end; end; //输出jpg procedure TMyWord.outjpg(wordfile, path, ptype: string); var n : olevariant; FileName : string; Totalpagenum, i, w, h : integer; pagew, pageH, pleft, ptop, pright, pbottom: single; isLand : boolean; begin self.FWord.Application.ScreenUpdating := false; self.MoveEnd(); Totalpagenum := FWord.Selection.Information[wdActiveEndPageNumber]; //获得总的页面 if getisok() then begin if Totalpagenum > Maxnum then begin Totalpagenum := Maxnum; end; end; ForceDirectories(path); initProgressBar(Totalpagenum); AutonumTotext(); try for i := 1 to Totalpagenum do begin self.gotopage(i, pagew, pageH, pleft, ptop, pright, pbottom, isLand); //showmessage(Format('%f,%f,%f,%f',[pagew, pageH, pleft, ptop])); //基本是像素为单位 FileName := path + '\' + Getonlyfilename(wordfile) + inttostr(i) + ptype; w := trunc(pagew - pleft - pright); //实际有效的宽度 h := trunc(pageH - ptop - pbottom); w := trunc(w * scalenum); h := trunc(h * scalenum); copyaspicture(FileName, w, h); if ProgressStep() then System.break; end; finally n := 1; FDoc.Undo(n); close(false); self.FWord.Application.ScreenUpdating := True; FreeProgressStep(); end; end; //是否保存关闭 procedure TMyWord.close(Saveed: boolean); var SaveChanges : olevariant; begin SaveChanges := Saveed; FWord.ActiveDocument.close(SaveChanges, EmptyParam, EmptyParam); end; //输出jpg,靠拷贝picture procedure TMyWord.outjpgbyCopyPicture(wordfilename: string); var n : olevariant; FileName : string; Totalpagenum, i, w, h : integer; pagew, pageH, pleft, ptop, pright, pbottom: single; isLand : boolean; FnewDoc : WordDocument; //文档对象 pageintarr : array of integer; //页面变化 procedure getpageinfo(); var i, num, pagenum : integer; pRange : Range; begin num := FDoc.Sections.Count; setlength(pageintarr, num); for i := 1 to num do begin pRange := FDoc.Sections.Item(i).Range; pagenum := pRange.Information[wdActiveEndPageNumber]; pageintarr[i - 1] := pagenum; //showmessage(Format('I=%d,%d', [i, pagenum])); end; end; //判断当前页是否分节 function getisbreak(n: integer): boolean; var i, num : integer; begin num := high(pageintarr); for i := 0 to num do begin if n = pageintarr[i] then begin result := True; exit; end; end; result := false; end; procedure copypageHeaderfooter(curBreak: integer); //拷贝页眉页脚 var srcrange, tgtrange : Range; Unit_ : olevariant; Count : olevariant; begin if FDoc.Sections.Count < curBreak then exit; //页眉 srcrange := FDoc.Sections.Item(curBreak).Headers.Item(1).Range; tgtrange := FnewDoc.Sections.Item(curBreak).Headers.Item(1).Range; srcrange.copyaspicture; FnewDoc.Activate; tgtrange.paste; tgtrange.select(); tgtrange.Start := length(tgtrange.Text); Unit_ := wdCharacter; Count := 1; tgtrange.Delete(Unit_, Count); //页脚 srcrange := FDoc.Sections.Item(curBreak).Footers.Item(1).Range; tgtrange := FnewDoc.Sections.Item(curBreak).Footers.Item(1).Range; srcrange.copyaspicture; tgtrange.paste; end; var curBreak : integer; //当前节数 isbreak : boolean; //是否分节 begin FnewDoc := self.newDocument(); self.FWord.Application.ScreenUpdating := false; FDoc.Activate; self.MoveEnd(); Totalpagenum := FWord.Selection.Information[wdActiveEndPageNumber]; //获得总的页面 if getisok() then begin if Totalpagenum > Maxnum then begin Totalpagenum := Maxnum; end; end; ForceDirectories(tempPath); initProgressBar(Totalpagenum); getpageinfo(); AutonumTotext(); try curBreak := 1; isbreak := True; for i := 1 to Totalpagenum do begin FDoc.Activate; self.gotopage(i, pagew, pageH, pleft, ptop, pright, pbottom, isLand); //FDoc.Activate; //showmessage(Format('%f,%f,%f,%f',[pagew, pageH, pleft, ptop])); //基本是像素为单位 FileName := tempPath + Format('p%d.jpg', [i]); w := trunc(pagew - pleft - pright); //实际有效的宽度 h := trunc(pageH - ptop - pbottom); w := trunc(w * 0.2); h := trunc(h * 0.2); //w := trunc(w * ScaleNum); //h := trunc(h * ScaleNum); copyaspicture(FileName, w, h); if ProgressStep() then System.break; if isbreak then begin //showmessage(Format('i=%d,curBreak=%d', [i,curBreak])); with FnewDoc.Sections.Item(curBreak).PageSetup do begin if isLand then Orientation := wdOrientLandscape else Orientation := wdOrientPortrait; PageWidth := pagew; PageHeight := pageH; TopMargin := ptop; LeftMargin := pleft; RightMargin := pright; BottomMargin := pbottom; end; copypageHeaderfooter(curBreak); end; FnewDoc.Activate(); self.MoveEnd(); AddPicture(FileName); isbreak := false; if (i < Totalpagenum) then begin MoveEnd(); if getisbreak(i) then //分节 begin insertPage(wdSectionBreakNextPage); //wdSectionBreakContinuous,wdSectionBreakNextPage); //插入分页分节符 inc(curBreak); isbreak := True; //showmessage('插入分节'); end else begin insertPage(wdPageBreak); //插入分页 //showmessage('插入分页'); end; end; end; deletefile(pchar(FileName)); finally n := 1; FDoc.Activate(); FDoc.Undo(n); close(false); FnewDoc.Activate(); Save(FnewDoc, wordfilename); self.FWord.Application.ScreenUpdating := True; FreeProgressStep(); end; end; //输出pdf,靠拷贝picture procedure TMyWord.outpdfbyCopyPicture(pdfFileName: string); const wd = 20; var k : integer; var Unit_ : olevariant; n : olevariant; Extend : olevariant; FileName : string; Totalpagenum, i, w, h, ww, hh : integer; pagew, pageH, pleft, ptop, pright, pbottom: single; isLand : boolean; begin AutonumTotext(); self.MoveEnd(); Totalpagenum := FWord.Selection.Information[wdActiveEndPageNumber]; //获得当前页面 if getisok() then begin if Totalpagenum > Maxnum then begin Totalpagenum := Maxnum; end; end; ForceDirectories(tempPath); MyPDF := TPDFDocument.Create(nil); MyPDF.AutoLaunch := openPDF; initProgressBar(Totalpagenum); try Createpdf(pdfFileName); for i := 1 to Totalpagenum do begin self.gotopage(i, pagew, pageH, pleft, ptop, pright, pbottom, isLand); //showmessage(Format('当前%d,总的%d', [i, Totalpagenum])); //showmessage(Format('%f,%f,%f,%f', [pagew, pageH, pleft, ptop])); //基本是像素为单位 FileName := tempPath + 'p.jpg'; w := trunc(pagew - pleft - pright); //实际有效的宽度 h := trunc(pageH - ptop - pbottom); ww := w; //hh := h; copyaspicture(FileName, w, h); hh := trunc(ww * h / w); //处理不满页的情况 k := MyPDF.AddImage(FileName, itcjpeg, -1, false, clwhite); {showmessage(Format('======1111==========当前%d,总的%d', [i, Totalpagenum])); } with MyPDF.CurrentPage do begin //Width := trunc(pagew); //height := trunc(pageH); if isLand then Orientation := poPageLandscape else Orientation := poPagePortrait; //ShowMessage(Format('%d,%d___%d,%d', [Width, height, w, h])); ShowImage(k, pleft - wd, ptop - wd, ww + 2 * wd, hh + 2 * wd, 0); //也是以像素为单位 //ShowImage(k, 0, 0, w, h, 0); writerightinfo(i); end; if ProgressStep() then System.break; if i < Totalpagenum then begin MyPDF.NewPage; end; //deletefile(pchar(FileName)); FWord.Selection.MoveDown(Unit_, n, Extend); //showmessage(Format('================当前%d,总的%d', [i, // Totalpagenum])); end; writepdfpagebottom(); MyPDF.EndDoc(); //FDoc.ActiveWindow.View.FullScreen:=True; finally n := 1; FDoc.Undo(n); close(false); MyPDF.Free; FreeProgressStep(); end; end; //输出pdf,靠抓屏 procedure TMyWord.outpdfbyScreenShot(pdfFileName: string); var k : integer; var Unit_ : olevariant; n : olevariant; Extend : olevariant; FileName : string; Totalpagenum, i, w, h : integer; begin self.MoveEnd(); Totalpagenum := FWord.Selection.Information[wdActiveEndPageNumber]; self.MoveFirst(); Unit_ := wdScreen; Extend := wdExtend; FWord.ScreenRefresh(); n := 1; FDoc.ActiveWindow.DocumentMap := false; //FDoc.ActiveWindow.View.Zoom.Percentage:=d; FDoc.ActiveWindow.View.ReadingLayout := True; FDoc.ActiveWindow.View.ReadingLayoutAllowMultiplePages := false; ForceDirectories(tempPath); MyPDF := TPDFDocument.Create(nil); try Createpdf(pdfFileName); if getisok() then begin if Totalpagenum > Maxnum then Totalpagenum := Maxnum; end; for i := 1 to Totalpagenum do begin FDoc.Application.ScreenRefresh(); Application.ProcessMessages(); sleep(1000); Application.ProcessMessages(); FileName := tempPath + inttostr(i) + '.jpg'; ScreenShot(FileName, w, h); k := MyPDF.AddImage(FileName, itcjpeg); with MyPDF.CurrentPage do begin ShowImage(k, 20, 10, Width, height, 0); writerightinfo(i); end; if i < Totalpagenum then begin MyPDF.NewPage; end; deletefile(pchar(FileName)); FWord.Selection.MoveDown(Unit_, n, Extend); end; writepdfpagebottom(); MyPDF.EndDoc(); //FDoc.ActiveWindow.View.FullScreen:=True; finally MyPDF.Free; end; end; function TMyWord.newDocument(): WordDocument; var FnewDoc : WordDocument; begin FnewDoc := FWord.Documents.Add(EmptyParam, EmptyParam, EmptyParam, EmptyParam); //文档对象 FnewDoc.Activate; result := FnewDoc; end; //提取所有图片 到指定目录 procedure TMyWord.SavePicture(dir: string); var i, num : integer; begin num := FDoc.InlineShapes.Count; ForceDirectories(dir); for i := 1 to num do begin if (FDoc.InlineShapes.Item(i).type_ = wdInlineShapePicture) then begin FDoc.InlineShapes.Item(i).select; FWord.Selection.copyaspicture(); copyaspicture(dir + Format('%d.jpg', [i])); end; end; end; //获得所有的表格 procedure TMyWord.GetAllTable(dir: string); var i, num : integer; begin num := FDoc.Tables.Count; for i := 1 to num do begin FDoc.Tables.Item(i).Range.select; FWord.Selection.copyaspicture(); copyaspicture(dir + Format('%d.jpg', [i])); end; end; //获得当前节数 function TMyWord.GetSectionNumber(): integer; begin //Result := FWord.Selection.Information[wdActiveEndSectionNumber];//返回总的有多少节 result := FWord.Selection.Information[wdActiveEndSectionNumber]; //返回总的有多少节 end; //何把WORD编号转换为普通文本? procedure TMyWord.AutonumTotext(); {Sub NumToTxt() \' \' NumToTxt Macro \' 宏在 2006-12-3 由 www.TopSage.com 创建 \' ActiveDocument.Content.ListFormat.ConvertNumbersToText End Sub } begin FDoc.Content.ListFormat.ConvertNumbersToText(EmptyParam); end; {某一个另存 个必须用VBA来实现了,在此文档的ThisDocument的代码页中输入以下代码,然后执行Sub SaveParagraph() 即可 Option Explicit Sub SaveParagraph() Dim i As Integer, PageNo As Integer Dim aDoc As Document Dim myDoc As Document Dim sPage As String Set myDoc = ThisDocument '文 档 视 图 设 定 为 页 面 方 式 ActiveWindow.View.Type = wdPageView myDoc.Repaginate '获 得 文 档 页 数 并 赋 值 给 变 量 PageNo PageNo = myDoc.BuiltInDocumentProperties(wdPropertyPages) For i = 1 To PageNo myDoc.Activate ' 光 标 移 动 到 文 档 某一 页 的 开 始 Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=i ' 全 选 文 档某一 页 的 所 有 内 容 Selection.EndKey Unit:=wdStory, Extend:=wdExtend sPage = Selection.Text '保存到一个文件中 Set aDoc = Documents.Add aDoc.Content.Text = sPage aDoc.SaveAs FileName:="c:\" & CInt(i) & ".doc" aDoc.Close Next End Sub } initialization finalization { if FMyWord <> nil then FMyWord.Free; } end.