Delphi与Word之间的融合技术 (0分)

  • 主题发起人 主题发起人 yzhshi
  • 开始时间 开始时间
Y

yzhshi

Unregistered / Unconfirmed
GUEST, unregistred user!
Delphi与Word之间的融合技术
(yzhshi@263.net)​
一、VBA代码含义
Microsoft Word是一个集成化环境,是美国微软公司的字处理系统,但是它决不仅仅是一个字处
理系统,它集成了Microsoft Visual Basic,可以通过编程来实现对Word功能的扩展。
Microsoft Visual Basic在word中的代码即Word的宏,通过编写Word宏,可实现一些文档处理的
自动化,如实现文档的自动备份、存盘等,可扩展Word文档的功能,因此,能够充分利用Word的
特性,甚至使Word成为自己软件的一部分。
Word的宏既有有利的一部分,因为它能够帮助我们实现文档的自动化,但是Word的宏也不是纯粹
的有利,有时它可能危害我们的文档、计算机系统甚至网络,从最开始的Taiwan NO1宏病毒到现
在的Melissa宏病毒,从最开始的简单的提示,耗尽系统资源到现在的乱发电子邮件,将个人的
信息发送到网络上,甚至向硬盘的Autoexec.bat(自动批处理文件)中添加Deltree C: -y,破坏
整个Windows系统。

二、Word中内嵌的Com技术
可以说Word是对Com技术支持最好的软件,这样说似乎是太极端了一点,但是Word提供的强大的编
程接口技术却能够是我们通过程序控制Word的任何一部分。无论是文件的打开、存盘、打印还是文
档中表格的自动绘制。
通过编程软件,可以灵活的操纵word,这里只以Borland Delphi为例,进行详细描述:
1、 在Delphi中调用Word软件/文件的方法
在Word中调用Word软件,归纳起来有三种方法:
。通过Delphi的控件TOleContainer 将Word嵌入
a.使用Delphi提供的Servers控件调用Word,使用Word的属性
b.通过真正的Com技术,将Office软件目录中文件MSWORD9.OLB中的类库全部导入Delphi中,
利用Com技术编程
c.使用CreateOleObject将启动Word,然后以Ole方式对Word进行控制。

2、 对几种方法的难易程度的判别

a.通过Delphi的控件TOleContainer 将Word嵌入

这是最简单的Ole嵌入,能够直接将Word文档调用,只需要使用ToleContainer.Run就可以将Word文
档直接启动。且这样启动的Word文档与Delphi程序是一个整体(从界面上看),但是它存在不可克
服的缺点,即不能通过Delphi控制Word文档,也就不能实现将灵活操纵Word的目的。

b.使用Delphi提供的Servers控件调用Word,使用Word的属性
使用Delphi的Servers控件来操纵Word,在编程时Delphi能够实现代码提示,总体上看能够较好的实
现Delphi对Word的控制,但是还有一些Word的功能不能在Delphi中调用(比如自己编写的VBA宏代码)。
且实现功能时本来在VBA代码中可选则参数在Delphi调用的时候必须添加,否则,连编译都不能通过。
本方式启动的Word与Delphi程序分属两个窗体。
此办法仅能作为一个参考。

c.通过真正的Com技术,将Office软件目录中文件MSWORD9.OLB中的类库全部导入Delphi中,
利用Com技术编程
利用真正的Com技术,将MsWord9.OLD文件类库导入,然后利用Com技术进行使用。
整体上类似使用Delphi的Servers控件,稍微比Servers控件麻烦,优缺点与Servers控件相同。

d.使用CreateOleObject将启动Word,然后以Ole方式对Word进行控制。
本办法是使用以CreateOleObjects方式调用Word,实际上还是Ole,但是这种方式能够真正做到完全
控制Word文件,能够使用Word的所有属性,包括自己编写的VBA宏代码。
与Servers控件和com技术相比,本方法能够真正地使用Word的各种属性,和在VBA中编写自己的代码
基本一样,可以缺省的代码也不需要使用。
本方式启动的Word与Delphi程序分属两个窗体。
缺点是使用本方法没有Delphi代码提示,所有异常处理均需要自己编写,可能编写时探索性知识比较多。

三、Word宏编辑器
Word能够真正地进行VBA代码的编辑,可以编写窗体、函数。
进入Word宏编辑器的方法:工具->宏->Visual Basic编辑器,可进入Visual Basic编辑器界面。
Word的Visual Basic编辑器界面和真正的Visual Basic编辑器基本相同,在此不再向详述。
在VBA代码中,可以添加用户窗体、模块、类模块。用户窗体、模块、类模块的概念和Visual Basic
完全相同。注释也与Visual Basic完全相同。
可以将光标停留在窗体、模块的任何一个子程序上,直接按“F5”运行当前子程序。

四、Word的宏的概述
Word充分地将文档编辑和VB结合起来,真正地实现文档的自动化。使用Word编程,类似于使用
Visual Basic,所不同的是,在Word中,能够直接运行某一个子程序,直接看见结果,Word的宏,
只能解释运行,而Visual Basic,现在已经能够编写成真正的机器码,从代码的保护上来说,应该尽
可能地减少Word的VBA代码数量,尤其是关键的代码。
VBA宏,可分成四种:
1、 和命令名相同的宏
如FileSave,FileOpen,如果在VBA代码中包含与Word同名的函数,则直接执行这些VBA代码,忽略Word
本身的命令。
2、 Word内特定的宏
这些宏包含AutoExec(启动 Word 或加载全局模板)、AutoNew(每次新建文档时)、AutoOpen(每次打
开已有文档时)、AutoClose(每次关闭文档时),AutoExit(退出 Word 或卸载全局模板时)。
如果VBA代码中含有这些名称的函数,则满足相应的条件,相应代码就自动执行。
3、 相应事件的VBA宏
这些宏是由事件触发的宏,如Document_Close在文档关闭的时候触发事件,Document_New在新建文档的时
候触发,Document_Open在打开文档的时候触发。
4、 独立的宏
自己编写的VBA代码,即不属于上面几种情况的VBA代码,可以被其他VBA代码调用,更重要的是,可以被
其他程序调用。
这样,我们就可以屏弃Word自动执行的宏,通过Delphi直接调用相应宏来达到目的。
五、Word命令宏的详细描述
Word本身的命令函数包含很多,但是无论是word联机帮助还是MSDN帮助,都没有这方面的介绍,因此只能
凭自己的实验取探索,初步探测的函数如下:
宏名 解释 注释
FileNew 新建
FileNewDefault 新建空白文档
FileSaveAs 另存为
FileOpen 打开
FileClose 关闭
FilePrint 打印
FilePrintPreview 打印预览
ToolsCustomize 工具栏里面的自定义
ToolsOptions 工具选项
ToolsRevisions 突出显示修订
ToolsReviewRevisions 接受或拒绝修订
ToolsRevisionMarksAccept 接受修订
ToolsRevisionMarksReject 拒绝修订
ToolsRevisionMarksToggle 修订
ToolsMacro 宏
ToolsRecordMacroToggle 录制新宏
ViewSecurity 安全性
ViewVBCode 查看VB编辑器环境
FileTemplates 模板和可加载项
ToolsProtectUnprotectDocument 解除对文档的保护
InsertHyperlink 插入超级链接
EditHyperlink 编辑超级链接
DeleteHyperlink 删除超级链接
EditLinks 查看、删除链接
EditPasteAsHyperlink 粘贴超级链接
FormatStyle 样式
EditBookMark 书签
 
这是我自己写的,结合自己的经验,在这里贡献出来,供大家共享。
里面有很多用词、观点也许不是特别确切,希望大家指出。
过几天再将一些具体的代码写出来(目前没有仔细整理)。
 
OleWord时一些用用的代码
yzhshi@263.net​

一、Delphi程序启动Word
采用CreateOleObjects的方法来启动Word,调用VBA代码,具体实现过程为:
首先使用GetActiveOleObject('Word.Application')判断当前内存中是否存在Word程序,如果存在,
则直接连接,如果没有Word程序,则使用CreateOleObject('Word.Application')启动Word

二、Delphi程序新建Word文稿
格式:WordDocuments.Add(Template,NewTemplate,DocumentType,Visible)
Template: 使用模板的名称,
NewTemplate: 新建文档的类型,True表示为模板,False表示为文档
DocumentType: 文档类型,默认为空白文档
Visible: 打捞的窗口是否可见

举例:Doc_Handle:=Word_Ole.Documents.Add(Template:='C:/Temlate.dot',NewTemplate:=False);

三、Delphi程序打开Word文稿
格式:WordDocuments.Open(FileName,ConfirmConversions,ReadOnly,PassWordDocument,
PasswordTemplate,Revent,WritePasswordDocument,WritePassWordTemplate,
Format,Encoding,Visible)

FileName: 文档名(包含路径)
Confirmconversions: 是否显示文件转换对话框
ReadOnly: 是否以只读方式打开文档
AddToRecentFiles: 是否将文件添加到"文件"菜单底部的最近使用文件列表中
PassWordDocument: 打开此文档时所需要的密码
PasswordTemplate: 打开此模板时所需要的密码
Revert: 如果文档已经,是否重新打开文档
WritePasswordDocument: 保存对文档更改时所需要的密码
WritePasswordTemplate: 保存对模板进行更改时所需要的密码
Format: 打开文档时所需使用的文件转换器
Encoding: 所使用的文档代码页
Visible: 打开文档的窗口是否可见

举例:
Doc_Handle:=Word_Ole.Documents.open(FileName:=Doc_File,ReadOnly:=False,
AddToRecentFiles:=False);

四、Delphi程序保存Word文稿
格式:WordDocuments.SaveAs(FileName, FileFormat, LockComments, Password,
AddToRecentFiles, WritePassword, ReadOnlyRecommended,
EmbedTrueTypeFonts, SaveNativePictureFormat, SaveFormsData,
SaveAsAOCELetter)

FileName: 文件名。默认为当前文件夹和文件名。
FileFormat 文档保存的格式。
LockComments 如果为 True,则此文档只允许进行批注。
Password 打开文档时的口令。
AddToRecentFiles 如果为True,则将文档添至"文件"菜单中最近使用的文档列表中。
WritePassword 保存对文档的修改所需的口令。
ReadOnlyRecommended 如果为 True,在每次打开文档时,Word 将建议用户采用只读方式。
EmbedTrueTypeFonts 如果为 True,则将文档与 TrueType 字体一起保存。
SaveNativePictureFormat 如果为 True,则从其他系统平台(例如 Macintosh)导入的图形仅保存其 Windows 版本。
SaveFormsData 如果为 True,则将窗体中用户输入的数据存为一条数据记录。
SaveAsAOCELetter 如果文档包含一个附加,当此属性值为 True 时,将文档存为一篇 AOCE 信笺(同时保存邮件)。

举例:
Word_Ole.Documents.SaveAs(FileName:=Doc_File,FileFormat=wdFormatDocument,
AddToRecentFiles=False);

五、从数据库读取文件到本地硬盘和从本地硬盘读取文件到数据库

在数据库上使用Image二进制字段保存,使用Stream流的方式。

创建文件流:
Word_FileStream:=TFileStream.Create(Target_Name,fmOpenWrite or fmCreate);
Word_FileStream.Position:=0;

保存到数据库的Image字段:
TBlobField(AdoQuery1.FieldByName(Column_Name)).SaveToStream(Word_FileStream);

从数据库读取文件到本地硬盘:
TBlobField(ADOQuery1.FieldByName(Column_Name)).loadfromStream(Word_FileStream);

释放文件流:
Word_FileStream.Free;

六、全局消息的定义
因为word和Delphi程序是两个软件,相互之间通讯比较麻烦,所以使用全局消息的方法进行。
全局消息必须首先注册,Windows返回系统空闲的消息号,当注册的消息相同时,
Windows系统返回同一个值,这样就保证了使用这个消息号在两个程序之间通讯。

定义消息的办法:
szMessageString: pchar = 'XIDIAN_11_Stone';
FMyJoinMessage := RegisterWindowMessage(szMessageString);

发送消息的方法:
SendMessage(对方句柄,消息,消息附带短变量,消息附带长变量)

七、Delphi程序接收消息的方法
Delphi接收消息有两种,一是重载特定消息,二是重载WndProc函数,在里面选择相应消息进行处理。
法一,每次只能处理一条消息,而法二能够同时处理多条消息。

对于法二,声明如下:
procedure WndProc(var Message: TMessage);override
必须注意,使用时需要在处理完自己消息处理后继承WndProc(Message)函数,否则系统会崩溃!

八、Word中Combo对话框的动态生成以及Change事件
建立类模块Combohander,在内部定义事件
Public WithEvents ComboBoxEvent As Office.CommandBarComboBox

定义Combo控件产生事件的模块
Dim ctlComboBoxHandler As New ComboBoxHandler

产生Combo对话框
Set Cbo_ChooseDoc = CommandBars("添加的菜单").Controls.Add(Type:=msoControlComboBox, Temporary:=True)

进行文件句柄设置,以产生Combo_Change事件
Set ctlComboBoxHandler.ComboBoxEvent = Cbo_ChooseDoc

产生事件后,在类模块Combohander内选择ComboBoxEvent的Change事件,即可书写事件代码
Sub ComboBoxEvent_Change(ByVal Ctrl As Office.CommandBarComboBox)

九、一些Word的事件
VBA代码中处理的Word事件有:Document_Close
Application事件中需要处理的有:DocumentBeforeClose,DocumentChange。

Document_Close:事件在文档关闭时产生事件
DocumentBeforeClose:在文档被关闭以前先于Word判断文档是否保存,给出相应提示并进行相应处理。
DocumentChange:文档切换,在文档从自己修改的文稿和其他人修改的文稿之间切换产生事件,
主要处理设置文档权限等。
 
自动化方面的知识
 
像你这样的好同志在DFW上已经是越来越少了。可惜DFW没有在一个贴子中给分的功能,
不然我一定给你加30分。

谢谢,收藏。
 
多谢。
其实对于技术问题,我从大富翁得到了许多,尤其是hubdog的葵花宝典,我也希望贡献自己
的一份力量,[red]众人拾柴火焰高![/red]
 
精神可嘉
 
精神可嘉,不过有些观点是错误的.例如:
使用Delphi的Server控件,Com类型库的引用和Com对象生成这三种方法实现的功能是
一样的,只是实现的形式不同而已.
 
你好,结合delphi 控件讲一下,有些参数还不明白
e-mail:jszmail@263.net
 
很好啊,若不用Server控件就不能够用delphi的code insight了.
 
写的不错,但是我想说一些不同的话,

CreateOLEObject创建的variant类型变量,运行期才通过IDispatch接口进行方法调用,所以没有Code Insight,
开发效率、运行效率都要差一点。(IDispatch接口是为适合Automation技术开发的,比COM更高级,更抽象)

http://www.delphibbs.com/delphibbs/dispq.asp?lid=680785
http://www.delphibbs.com/delphibbs/dispq.asp?lid=420919

Delphi Servers 组件和Import Library是一回事来着,使用Import Library会更加通用一点,除了Word,
其它的支持Automation的应用程序都可以使用,比如Autocad、IE等等。但是Import Library有很多的bug,
经常出错。这一点玩过COM编程的人都知道,但我还是推荐使用这套技术进行COM或者Automation工作,效
率高的多。hubdog是这方面的专家,你们可以等他来介绍介绍。

最后我推荐Binh Ly的站点,他是Borland的COM专家,如果经常逛Borland的Automation新闻组,你肯定认
识他,站点有很多介绍和工具下载,大家可以自己看看。Delphi 4编程技术内幕的作者Chris Clvert也是
个中好手,他的站点资料多多。

http://www.techvanguards.com/
http://www.delphibbs.com/delphibbs/dispq.asp?lid=738352
 
这里给出一个Excel的操作单元,函概了部分常用Excel操作,不是我写的,是从Experts-Exchange
看到后收藏起来的,给大家参考。

// 该文件操作单元封装了大部分的Excel操作
// use to manipulate Excel xls File
// Dragon P.C. <2000.05.10>
unit ExcelUnit;

interface

uses
Dialogs, Messages, SysUtils, Grids, Cmp_Sec, ComObj, Ads_Misc;

{!~Add a blank WorkSheet}
Function ExcelAddWorkSheet(Excel : Variant): Boolean;

{!~Close Excel}
Function ExcelClose(Excel : Variant; SaveAll: Boolean): Boolean;

{!~Returns the Column String Value from its integer equilavent.}
Function ExcelColIntToStr(ColNum: Integer): ShortString;

{!~Returns the Column Integer Value from its Alpha equilavent.}
Function ExcelColStrToInt(ColStr: ShortString): Integer;

{!~Close All Workbooks. All workbooks can be saved or not.}
Function ExcelCloseWorkBooks(Excel : Variant; SaveAll: Boolean): Boolean;

{!~Copies a range of Excel Cells to a Delphi StringGrid. If successful
True is returned, False otherwise. If SizeStringGridToFit is True
then the StringGrid is resized to be exactly the correct dimensions to
receive the input Excel cells, otherwise the StringGrid is not resized.
If ClearStringGridFirst is true then any cells outside the input range
are cleared, otherwise existing values are retained. Please not that the
Excel cell coordinates are "1" based and the Delphi StringGrid coordinates
are zero based.}
Function ExcelCopyToStringGrid(
Excel : Variant;
ExcelFirstRow : Integer;
ExcelFirstCol : Integer;
ExcelLastRow : Integer;
ExcelLastCol : Integer;
StringGrid : TStringGrid;
StringGridFirstRow : Integer;
StringGridFirstCol : Integer;
{Make the StringGrid the same size as the input range}
SizeStringGridToFit : Boolean;
{cells outside input range in StringGrid are cleared}
ClearStringGridFirst : Boolean
): Boolean;

{!~Delete a WorkSheet by Name}
Function ExcelDeleteWorkSheet(
Excel : Variant;
SheetName : ShortString): Boolean;

{!~Moves the cursor to the last row and column}
Function ExcelEnd(Excel : Variant): Boolean;

{!~Finds A value and moves the cursor there.
If the value is not found then the cursor does not move.
If nothing is found then false is returned, True otherwise.}
Function ExcelFind(
Excel : Variant;
FindString : ShortString): Boolean;

{!~Finds A value in a range and moves the cursor there.
If the value is not found then the cursor does not move.
If nothing is found then false is returned, True otherwise.}
Function ExcelFindInRange(
Excel : Variant;
FindString : ShortString;
TopRow : Integer;
LeftCol : Integer;
LastRow : Integer;
LastCol : Integer): Boolean;

{!~Finds A value in a range and moves the cursor there. If the value is
not found then the cursor does not move. If nothing is found then
false is returned, True otherwise. The search directions can be defined.
If you want row searches to go from left to right then SearchRight should
be set to true, False otherwise. If you want column searches to go from
top to bottom then SearchDown should be set to true, false otherwise.
If RowsFirst is set to true then all the columns in a complete row will be
searched.}
Function ExcelFindValue(
Excel : Variant;
FindString : ShortString;
TopRow : Integer;
LeftCol : Integer;
LastRow : Integer;
LastCol : Integer;
SearchRight : Boolean;
SearchDown : Boolean;
RowsFirst : Boolean
): Boolean;

{!~Returns The First Col}
Function ExcelFirstCol(Excel : Variant): Integer;

{!~Returns The First Row}
Function ExcelFirstRow(Excel : Variant): Integer;

{!~Returns the name of the currently active worksheet
as a shortstring}
Function ExcelGetActiveSheetName(Excel : Variant): ShortString;

{!~Gets the formula in a cell.}
Function ExcelGetCellFormula(
Excel : Variant;
RowNum, ColNum: Integer): ShortString;

{!~Returns the contents of a cell as a shortstring}
Function ExcelGetCellValue(Excel : Variant; RowNum, ColNum: Integer): ShortString;

{!~Returns the the current column}
Function ExcelGetCol(Excel : Variant): Integer;

{!~Returns the the current row}
Function ExcelGetRow(Excel : Variant): Integer;

{!~Moves the cursor to the last column}
Function ExcelGoToLastCol(Excel : Variant): Boolean;

{!~Moves the cursor to the last row}
Function ExcelGoToLastRow(Excel : Variant): Boolean;

{!~Moves the cursor to the Leftmost Column}
Function ExcelGoToLeftmostCol(Excel : Variant): Boolean;

{!~Moves the cursor to the Top row}
Function ExcelGoToTopRow(Excel : Variant): Boolean;

{!~Moves the cursor to Home position, i.e., A1}
Function ExcelHome(Excel : Variant): Boolean;

{!~Returns The Last Column}
Function ExcelLastCol(Excel : Variant): Integer;

{!~Returns The Last Row}
Function ExcelLastRow(Excel : Variant): Integer;

{!~Open the file you want to work within Excel. If you want to
take advantage of optional parameters then you should use
ExcelOpenFileComplex}
Function ExcelOpenFile(Excel : Variant; FileName : String): Boolean;

{!~Open the file you want to work within Excel. If you want to
take advantage of optional parameters then you should use
ExcelOpenFileComplex}
Function ExcelOpenFileComplex(
Excel : Variant;
FileName : String;
UpdateLinks : Integer;
ReadOnly : Boolean;
Format : Integer;
Password : ShortString): Boolean;

{!~Saves the range on the currently active sheet
to to values only.}
Function ExcelPasteValuesOnly(
Excel : Variant;
ExcelFirstRow : Integer;
ExcelFirstCol : Integer;
ExcelLastRow : Integer;
ExcelLastCol : Integer): Boolean;

{!~Renames a worksheet.}
Function ExcelRenameSheet(
Excel : Variant;
OldName : ShortString;
NewName : ShortString): Boolean;

{!~Saves the range on the currently active sheet
to a DBase 4 table.}
Function ExcelSaveAsDBase4(
Excel : Variant;
ExcelFirstRow : Integer;
ExcelFirstCol : Integer;
ExcelLastRow : Integer;
ExcelLastCol : Integer;
OutFilePath : ShortString;
OutFileName : ShortString): Boolean;

{!~Saves the range on the currently active sheet
to a text file.}
Function ExcelSaveAsText(
Excel : Variant;
ExcelFirstRow : Integer;
ExcelFirstCol : Integer;
ExcelLastRow : Integer;
ExcelLastCol : Integer;
OutFilePath : ShortString;
OutFileName : ShortString): Boolean;

{!~Selects a range on the currently active sheet. From the
current cursor position a block is selected down and to the right.
The block proceeds down until an empty row is encountered. The
block proceeds right until an empty column is encountered.}
Function ExcelSelectBlock(
Excel : Variant;
FirstRow : Integer;
FirstCol : Integer): Boolean;

{!~Selects a range on the currently active sheet. From the
current cursor position a block is selected that contains
the currently active cell. The block proceeds in each
direction until an empty row or column is encountered.}
Function ExcelSelectBlockWhole(Excel: Variant): Boolean;

{!~Selects a cell on the currently active sheet}
Function ExcelSelectCell(Excel : Variant; RowNum, ColNum: Integer): Boolean;

{!~Selects a range on the currently active sheet}
Function ExcelSelectRange(
Excel : Variant;
FirstRow : Integer;
FirstCol : Integer;
LastRow : Integer;
LastCol : Integer): Boolean;

{!~Selects an Excel Sheet By Name}
Function ExcelSelectSheetByName(Excel : Variant; SheetName: String): Boolean;

{!~Sets the formula in a cell. Remember to include the equals sign "=".
If the function fails False is returned, True otherwise.}
Function ExcelSetCellFormula(
Excel : Variant;
FormulaString : ShortString;
RowNum, ColNum: Integer): Boolean;

{!~Sets the contents of a cell as a shortstring}
Function ExcelSetCellValue(
Excel : Variant;
RowNum, ColNum: Integer;
Value : ShortString): Boolean;

{!~Sets a Column Width on the currently active sheet}
Function ExcelSetColumnWidth(
Excel : Variant;
ColNum : Integer;
ColumnWidth: Integer): Boolean;

{!~Set Excel Visibility}
Function ExcelSetVisible(
Excel : Variant;
IsVisible: Boolean): Boolean;

{!~Saves the range on the currently active sheet
to values only.}
Function ExcelValuesOnly(
Excel : Variant;
ExcelFirstRow : Integer;
ExcelFirstCol : Integer;
ExcelLastRow : Integer;
ExcelLastCol : Integer): Boolean;

{!~Returns the Excel Version as a ShortString.}
Function ExcelVersion(Excel: Variant): ShortString;

Function IsBlockColSide(
Excel : Variant;
RowNum: Integer;
ColNum: Integer): Boolean; Forward;

Function IsBlockRowSide(
Excel : Variant;
RowNum: Integer;
ColNum: Integer): Boolean; Forward;


implementation


type
//Declare the constants used by Excel
SourceType = (xlConsolidation, xlDatabase, xlExternal, xlPivotTable);
Orientation = (xlHidden, xlRowField, xlColumnField, xlPageField, xlDataField);
RangeEnd = (NoValue, xlToLeft, xlToRight, xlUp, xlDown);
ExcelPasteType = (xlAllExceptBorders,xlNotes,xlFormats,xlValues,xlFormulas,xlAll);

{CAUTION!!! THESE OUTPUTS ARE ALL GARBLED! YOU SELECT xlDBF3 AND EXCEL
OUTPUTS A xlCSV.}
FileFormat = (xlAddIn, xlCSV, xlCSVMac, xlCSVMSDOS, xlCSVWindows, xlDBF2,
xlDBF3, xlDBF4, xlDIF, xlExcel2, xlExcel3, xlExcel4,
xlExcel4Workbook, xlIntlAddIn, xlIntlMacro, xlNormal,
xlSYLK, xlTemplate, xlText, xlTextMac, xlTextMSDOS,
xlTextWindows, xlTextPrinter, xlWK1, xlWK3, xlWKS,
xlWQ1, xlWK3FM3, xlWK1FMT, xlWK1ALL);

{Add a blank WorkSheet}
Function ExcelAddWorkSheet(Excel : Variant): Boolean;
Begin
Result := True;
Try
Excel.Worksheets.Add;
Except
MessageDlg('Unable to add a new worksheet', mtError, [mbOK], 0);
Result := False;
End;
End;

{Sets Excel Visibility}
Function ExcelSetVisible(Excel : Variant;IsVisible: Boolean): Boolean;
Begin
Result := True;
Try
Excel.Visible := IsVisible;
Except
MessageDlg('Unable to Excel Visibility', mtError, [mbOK], 0);
Result := False;
End;
End;

{Close Excel}
Function ExcelClose(Excel : Variant; SaveAll: Boolean): Boolean;
Begin
Result := True;
Try
ExcelCloseWorkBooks(Excel, SaveAll);
Excel.Quit;
Except
MessageDlg('Unable to Close Excel', mtError, [mbOK], 0);
Result := False;
End;
End;

{Close All Workbooks. All workbooks can be saved or not.}
Function ExcelCloseWorkBooks(Excel : Variant; SaveAll: Boolean): Boolean;
var
loop: byte;
Begin
Result := True;
Try
For loop := 1 to Excel.Workbooks.Count Do
Excel.Workbooks[1].Close[SaveAll];
Except
Result := False;
End;
End;

{Selects an Excel Sheet By Name}
Function ExcelSelectSheetByName(Excel : Variant; SheetName: String): Boolean;
Begin
Result := True;
Try
Excel.Sheets[SheetName].Select;
Except
Result := False;
End;
End;

{Selects a cell on the currently active sheet}
Function ExcelSelectCell(Excel : Variant; RowNum, ColNum: Integer): Boolean;
Begin
Result := True;
Try
Excel.ActiveSheet.Cells[RowNum, ColNum].Select;
Except
Result := False;
End;
End;

{Returns the contents of a cell as a shortstring}
Function ExcelGetCellValue(Excel : Variant; RowNum, ColNum: Integer): ShortString;
Begin
Result := '';
Try
Result := Excel.Cells[RowNum, ColNum].Value;
Except
Result := '';
End;
End;

{Returns the the current row}
Function ExcelGetRow(Excel : Variant): Integer;
Begin
Result := 1;
Try
Result := Excel.ActiveCell.Row;
Except
Result := 1;
End;
End;

{Returns the the current column}
Function ExcelGetCol(Excel : Variant): Integer;
Begin
Result := 1;
Try
Result := Excel.ActiveCell.Column;
Except
Result := 1;
End;
End;

{Moves the cursor to the last column}
Function ExcelGoToLastCol(Excel : Variant): Boolean;
Begin
Result := True;
Try
Excel.Selection.End[xlToRight].Select;
Except
Result := False;
End;
End;

{Moves the cursor to the last row}
Function ExcelGoToLastRow(Excel : Variant): Boolean;
Begin
Result := True;
Try
Excel.Selection.End[xlDown].Select;
Except
Result := False;
End;
End;

{Moves the cursor to the Top row}
Function ExcelGoToTopRow(Excel : Variant): Boolean;
Begin
Result := True;
Try
Excel.Selection.End[xlUp].Select;
Except
Result := False;
End;
End;

{Moves the cursor to the Leftmost Column}
Function ExcelGoToLeftmostCol(Excel : Variant): Boolean;
Begin
Result := True;
Try
Excel.Selection.End[xlToLeft].Select;
Except
Result := False;
End;
End;

{Moves the cursor to Home position}
Function ExcelHome(Excel : Variant): Boolean;
Begin
Result := True;
Try
Excel.ActiveSheet.Cells[1,1].Select;
Except
Result := False;
End;
End;

{Moves the cursor to the last row and column}
Function ExcelEnd(Excel : Variant): Boolean;
Begin
Result := True;
Try
Excel.Selection.End[xlDown].Select;
Excel.Selection.End[xlToRight].Select;
Except
Result := False;
End;
End;

{Returns The Last Column}
Function ExcelLastCol(Excel : Variant): Integer;
Var
CurRow : Integer;
CurCol : Integer;
Begin
Result := 1;
Try
CurRow := Excel.ActiveCell.Row;
CurCol := Excel.ActiveCell.Column;
Result := CurCol;
Excel.Selection.End[xlToRight].Select;
Result := Excel.ActiveCell.Column;
Excel.ActiveSheet.Cells[CurRow, CurCol].Select;
Except
End;
End;

{Returns The Last Row}
Function ExcelLastRow(Excel : Variant): Integer;
Var
CurRow : Integer;
CurCol : Integer;
Begin
Result := 1;
Try
CurRow := Excel.ActiveCell.Row;
CurCol := Excel.ActiveCell.Column;
Result := CurRow;
Excel.Selection.End[xlDown].Select;
Result := Excel.ActiveCell.Row;
Excel.ActiveSheet.Cells[CurRow, CurCol].Select;
Except
End;
End;

{Returns The First Row}
Function ExcelFirstRow(Excel : Variant): Integer;
Var
CurRow : Integer;
CurCol : Integer;
Begin
Result := 1;
Try
CurRow := Excel.ActiveCell.Row;
CurCol := Excel.ActiveCell.Column;
Result := CurRow;
Excel.Selection.End[xlUp].Select;
Result := Excel.ActiveCell.Row;
Excel.ActiveSheet.Cells[CurRow, CurCol].Select;
Except
End;
End;

{Returns The First Col}
Function ExcelFirstCol(Excel : Variant): Integer;
Var
CurRow : Integer;
CurCol : Integer;
Begin
Result := 1;
Try
CurRow := Excel.ActiveCell.Row;
CurCol := Excel.ActiveCell.Column;
Result := CurRow;
Excel.Selection.End[xlToLeft].Select;
Result := Excel.ActiveCell.Column;
Excel.ActiveSheet.Cells[CurRow, CurCol].Select;
Except
End;
End;

{Finds A value in a range and moves the cursor there. If the value is
not found then the cursor does not move. If nothing is found then
false is returned, True otherwise.}
Function ExcelFindValue(
Excel : Variant;
FindString : ShortString;
TopRow : Integer;
LeftCol : Integer;
LastRow : Integer;
LastCol : Integer;
SearchRight : Boolean;
SearchDown : Boolean;
RowsFirst : Boolean
): Boolean;
Var
CurRow : Integer;
CurCol : Integer;
TopRowN : Integer;
LeftColN : Integer;
LastRowN : Integer;
LastColN : Integer;
ColLoop : Integer;
RowLoop : Integer;
CellValue : ShortString;
FoundRow : Integer;
FoundCol : Integer;
Found : Boolean;
Begin
Result := False;
Try
Found := False;
FindString := UpperCase(FindString);
CurRow := Excel.ActiveCell.Row;
CurCol := Excel.ActiveCell.Column;
FoundRow := CurRow;
FoundCol := CurCol;

If SearchRight Then
Begin
LeftColN := LeftCol;
LastColN := LastCol;
End
Else
Begin
LeftColN := LastCol;
LastColN := LeftCol;
End;

If SearchDown Then
Begin
TopRowN := TopRow;
LastRowN := LastRow;
End
Else
Begin
TopRowN := LastRow;
LastRowN := TopRow;
End;
If RowsFirst Then
Begin
For ColLoop := LeftColN To LastColN Do
Begin
For RowLoop := TopRowN To LastRowN Do
Begin
CellValue := ExcelGetCellValue(Excel,RowLoop, ColLoop);
If UpperCase(CellValue) = FindString Then
Begin
FoundRow := RowLoop;
FoundCol := ColLoop;
Found := True;
Break;
End;
End;
If Found Then Break;
End;
End
Else
Begin
For RowLoop := TopRowN To LastRowN Do
Begin
For ColLoop := LeftColN To LastColN Do
Begin
CellValue := ExcelGetCellValue(Excel,RowLoop, ColLoop);
If UpperCase(CellValue) = FindString Then
Begin
FoundRow := RowLoop;
FoundCol := ColLoop;
Found := True;
Break;
End;
End;
If Found Then Break;
End;
End;
Excel.Cells[FoundRow, FoundCol].Activate;
Result := Found;
Except
Result := False;
End;
End;

{Finds A value in a range and moves the cursor there. If the value is
not found then the cursor does not move. If nothing is found then
false is returned, True otherwise.}
Function ExcelFindInRange(
Excel : Variant;
FindString : ShortString;
TopRow : Integer;
LeftCol : Integer;
LastRow : Integer;
LastCol : Integer): Boolean;
Begin
Result :=
ExcelFindValue(
Excel,
FindString,
TopRow,
LeftCol,
LastRow,
LastCol,
True,
True,
True);
End;

{Finds A value and moves the cursor there. If the value is
not found then the cursor does not move. If nothing is found then
false is returned, True otherwise.}
Function ExcelFind(
Excel : Variant;
FindString : ShortString): Boolean;
Begin
Result :=
ExcelFindInRange(
Excel,
FindString,
ExcelFirstRow(Excel),
ExcelFirstCol(Excel),
ExcelLastRow(Excel),
ExcelLastCol(Excel));
End;

{!~Copies a range of Excel Cells to a Delphi StringGrid. If successful
True is returned, False otherwise. If SizeStringGridToFit is True
then the StringGrid is resized to be exactly the correct dimensions to
receive the input Excel cells, otherwise the StringGrid is not resized.
If ClearStringGridFirst is true then any cells outside the input range
are cleared, otherwise existing values are retained. Please not that the
Excel cell coordinates are "1" based and the Delphi StringGrid coordinates
are zero based.}
Function ExcelCopyToStringGrid(
Excel : Variant;
ExcelFirstRow : Integer;
ExcelFirstCol : Integer;
ExcelLastRow : Integer;
ExcelLastCol : Integer;
StringGrid : TStringGrid;
StringGridFirstRow : Integer;
StringGridFirstCol : Integer;
SizeStringGridToFit : Boolean; {Make the StringGrid the same size as the input range}
ClearStringGridFirst : Boolean {cells outside input range in StringGrid are cleared}
): Boolean;
Var
C,R : Integer;
Begin
Result := False;
If ExcelLastCol < ExcelFirstCol Then Exit;
If ExcelLastRow < ExcelFirstRow Then Exit;
If (ExcelFirstRow < 1) Or (ExcelFirstRow > 255) Then Exit;
If (ExcelFirstCol < 1) Or (ExcelFirstCol > 30000) Then Exit;
If (ExcelLastRow < 1) Or (ExcelLastRow > 255) Then Exit;
If (ExcelLastCol < 1) Or (ExcelLastCol > 30000) Then Exit;
If StringGrid = nil Then Exit;
If SizeStringGridToFit Then
Begin
StringGrid.ColCount := ExcelLastCol - ExcelFirstCol + StringGridFirstCol + 1;
StringGrid.RowCount := ExcelLastRow - ExcelFirstRow + StringGridFirstRow + 1;
End;
If ClearStringGridFirst Then
Begin
C := StringGrid.ColCount;
R := StringGrid.RowCount;
StringGrid.ColCount := 1;
StringGrid.RowCount := 1;
StringGrid.Cells[0,0] := '';
StringGrid.ColCount := C;
StringGrid.RowCount := R;
End;

Result := True;
For R := ExcelFirstRow To ExcelLastRow Do
Begin
For C := ExcelFirstCol To ExcelLastCol Do
Begin
Try
StringGrid.Cells[
C - ExcelFirstCol + StringGridFirstCol,
R - ExcelFirstRow + StringGridFirstRow] :=
Excel.Cells[R, C];
Except
Result := False;
End;
End;
End;
End;

{!~Sets the formula in a cell. Remember to include the equals sign "=".
If the function fails False is returned, True otherwise.}
Function ExcelSetCellFormula(
Excel : Variant;
FormulaString : ShortString;
RowNum, ColNum: Integer): Boolean;
Begin
Result := True;
Try
Excel.
ActiveSheet.
Cells[RowNum, ColNum].
Formula := FormulaString;
Except
Result := False;
End;
End;

{!~Returns the Column String Value from its integer equilavent.}
Function ExcelColIntToStr(ColNum: Integer): ShortString;
Var
ColStr : ShortString;
Multiplier: Integer;
Remainder : Integer;
Begin
Result := '';
If ColNum < 1 Then Exit;
If ColNum > 256 Then Exit;
Multiplier := ColNum div 26;
Remainder := ColNum Mod 26;
If ColNum <= 26 Then
Begin
ColStr[1] := ' ';
If Remainder = 0 Then
Begin
ColStr[2] := 'Z';
End
Else
Begin
ColStr[2] := Chr(Remainder+64);
End;
End
Else
Begin
If Remainder = 0 Then
Begin
If Multiplier = 1 Then
Begin
ColStr[1] := ' ';
ColStr[2] := 'Z';
End
Else
Begin
ColStr[1] := Chr(Multiplier+64-1);
ColStr[2] := 'Z';
End;
End
Else
Begin
ColStr[1] := Chr(Multiplier+64);
ColStr[2] := Chr(Remainder+64);
End;
End;
If ColStr[1] = ' ' Then
Begin
Result := Result + ColStr[2];
End
Else
Begin
Result := Result + ColStr[1] + ColStr[2];
End;
Result := Result;
End;

{!~Returns the Column Integer Value from its Alpha equilavent.}
Function ExcelColStrToInt(ColStr: ShortString): Integer;
Var
ColStrNew : ShortString;
i : Integer;
RetVal : Integer;
Multiplier : Integer;
Remainder : Integer;
Begin
RetVal := 1;
Result := RetVal;
ColStrNew := '';
For i := 1 To Length(ColStr) Do
Begin
If ((Ord(ColStr) >= 65) And
( Ord(ColStr) <= 90)) Or
((Ord(ColStr) >= 97) And
( Ord(ColStr) <= 122)) Then
Begin
ColStrNew := ColStrNew + UpperCase(ColStr);
End;
End;
If Length(ColStrNew) < 1 Then Exit;
If Length(ColStrNew) < 2 Then
Begin
RetVal := Ord(ColStrNew[1])-64;
End
Else
Begin
Multiplier := Ord(ColStrNew[1])-64;
Remainder := Ord(ColStrNew[2])-64;
Retval := (Multiplier * 26) + Remainder;
End;
Result := RetVal;
End;

{!~Sets the contents of a cell as a shortstring}
Function ExcelSetCellValue(
Excel : Variant;
RowNum, ColNum: Integer;
Value : ShortString): Boolean;
Begin
Result := False;
Try
Excel.Cells[RowNum, ColNum].Value := Value;
Result := True;
Except
Result := False;
End;
End;

{!~Open the file you want to work within Excel. If you want to
take advantage of optional parameters then you should use
ExcelOpenFileComplex}
Function ExcelOpenFile(Excel : Variant; FileName : String): Boolean;
Begin
Result := True;
try
//Open the database that we want to work with
Excel.Workbooks.Open[FileName];
except
MessageDlg('Unable to locate '+FileName, mtError, [mbOK], 0);
Result := False;
end;
End;

{!~Open the file you want to work within Excel.

Excel
The OLEObject passed as an argument.

FileName
Required. Specifies the filename of the workbook to open.

UpdateLinks
Specifies how links in the file are updated. If this
argument is omitted, the user is prompted to determine
how to update links. Otherwise, this argument is one of
the values shown in the following table.
Value Meaning
0 No updates
1 Updates external but not remote references
2 Updates remote but not external references
3 Updates both remote and external references

If Microsoft Excel is opening a file in the WKS, WK1, or
WK3 format and the updateLinks argument is 2, Microsoft
Excel generates charts from the graphs attached to the file.
If the argument is 0, no charts are created.

ReadOnly
If True, the workbook is opened in read-only mode.

Format
If Microsoft Excel is opening a text file, this argument
specifies the delimiter character, as shown in the following
table. If this argument is omitted, the current delimiter
is used.

Value Delimiter
1 Tabs
2 Commas
3 Spaces
4 Semicolons
5 Nothing
6 Custom character, see the delimiter argument.

Password
A string containing the password required to open a
protected workbook. If omitted and the workbook requires
a password, the user is prompted for the password.
}

Function ExcelOpenFileComplex(
Excel : Variant;
FileName : String;
UpdateLinks : Integer;
ReadOnly : Boolean;
Format : Integer;
Password : ShortString): Boolean;
Begin
Result := True;
try
//Open the database that we want to work with
Excel.
Workbooks.
Open[
FileName,
UpdateLinks,
ReadOnly,
Format,
Password];
except
MessageDlg('Unable to locate '+FileName, mtError, [mbOK], 0);
Result := False;
end;
End;

{!~Saves the range on the currently active sheet
to a DBase 4 table.}
Function ExcelSaveAsDBase4(
Excel : Variant;
ExcelFirstRow : Integer;
ExcelFirstCol : Integer;
ExcelLastRow : Integer;
ExcelLastCol : Integer;
OutFilePath : ShortString;
OutFileName : ShortString): Boolean;
{
OutFileFormat: Use one of the following
xlAddIn xlExcel3 xlTextMSDOS
xlCSV xlExcel4 xlTextWindows
xlCSVMac xlExcel4Workbook xlTextPrinter
xlCSVMSDOS xlIntlAddIn xlWK1
xlCSVWindows xlIntlMacro xlWK3
xlDBF2 xlNormal xlWKS
xlDBF3 xlSYLK xlWQ1
xlDBF4 xlTemplate xlWK3FM3
xlDIF xlText xlWK1FMT
xlExcel2 xlTextMac xlWK1ALL
}
Begin
Result := False;
Try
If IsTable(
OutFilePath,
OutFileName+'.dbf')
Then
Begin
If Not DBDeleteTable(
OutFilePath,
OutFileName+'.dbf')
Then
Begin
Msg('Could not delete the '+
OutFilePath+OutFileName+'.dbf'+' Table');
Msg('Process Aborted');
Exit;
End;
End;
If ExcelVersion(Excel) = '8.0' Then
Begin
ExcelSelectCell(Excel,ExcelFirstRow,ExcelFirstCol);
ExcelSelectBlockWhole(Excel);
//Excel.SendKeys('^+{END}');
End
Else
Begin
Excel.
Range(
ExcelColIntToStr(ExcelFirstCol)+
IntToStr(ExcelFirstRow)+
':'+
ExcelColIntToStr(ExcelLastCol)+
IntToStr(ExcelLastRow)
).
Select;
End;
{
FileFormat = (xlAddIn, xlCSV, xlCSVMac, xlCSVMSDOS, xlCSVWindows, xlDBF2,
xlDBF3, xlDBF4, xlDIF, xlExcel2, xlExcel3, xlExcel4,
xlExcel4Workbook, xlIntlAddIn, xlIntlMacro, xlNormal,
xlSYLK, xlTemplate, xlText, xlTextMac, xlTextMSDOS,
xlTextWindows, xlTextPrinter, xlWK1, xlWK3, xlWKS,
xlWQ1, xlWK3FM3, xlWK1FMT, xlWK1ALL);
}
{
//CHECKING OUT THE GARBLED OUTPUT
// Produces an *.xls
Excel.
ActiveSheet.
SaveAs(
OutFilePath+OutFileName+'02',xlCSV);

// Produces an *.txt
Excel.
ActiveSheet.
SaveAs(
OutFilePath+OutFileName+'04',xlCSVMSDOS);

// Produces nothing
Excel.
ActiveSheet.
SaveAs(
OutFilePath+OutFileName+'05',xlCSVWindows);

// Produces nothing
Excel.
ActiveSheet.
SaveAs(
OutFilePath+OutFileName+'06',xlDBF2);

// Produces an *.txt
Excel.
ActiveSheet.
SaveAs(
OutFilePath+OutFileName+'07',xlDBF3);

// Produces an *.dbf
Excel.
ActiveSheet.
SaveAs(
OutFilePath+OutFileName+'08',xlDBF4);
// Produces an *.dbf
Excel.
ActiveSheet.
SaveAs(
OutFilePath+OutFileName+'09',xlDIF);
// Produces an *.dif
Excel.
ActiveSheet.
SaveAs(
OutFilePath+OutFileName+'10',xlExcel2);
// Produces an *.slk
Excel.
ActiveSheet.
SaveAs(
OutFilePath+OutFileName+'11',xlExcel3);
// Produces an *.dbf
Excel.
ActiveSheet.
SaveAs(
OutFilePath+OutFileName+'12',xlExcel4);
}
Excel.
ActiveSheet.
SaveAs(
OutFilePath+OutFileName,xlExcel4);
Result := True;
Except
Result := False;
End;
End;

{!~Saves the range on the currently active sheet
to a text file.}
Function ExcelSaveAsText(
Excel : Variant;
ExcelFirstRow : Integer;
ExcelFirstCol : Integer;
ExcelLastRow : Integer;
ExcelLastCol : Integer;
OutFilePath : ShortString;
OutFileName : ShortString): Boolean;
{
OutFileFormat: Use one of the following
xlAddIn xlExcel3 xlTextMSDOS
xlCSV xlExcel4 xlTextWindows
xlCSVMac xlExcel4Workbook xlTextPrinter
xlCSVMSDOS xlIntlAddIn xlWK1
xlCSVWindows xlIntlMacro xlWK3
xlDBF2 xlNormal xlWKS
xlDBF3 xlSYLK xlWQ1
xlDBF4 xlTemplate xlWK3FM3
xlDIF xlText xlWK1FMT
xlExcel2 xlTextMac xlWK1ALL
}
Var
FullOutName : String;
Begin
Result := False;
Try
If OutFilePath <> '' Then
Begin
If Not (Copy(OutFilePath,Length(OutFilePath),1) = '/') Then
Begin
OutFilePath := OutFilePath + '/';
End;
End;
FullOutName := OutFilePath + OutFileName;
If FileExists(FullOutName) Then DeleteFile(FullOutName);

If ExcelVersion(Excel) = '8.0' Then
Begin
ExcelSelectCell(Excel,ExcelFirstRow,ExcelFirstCol);
ExcelSelectBlockWhole(Excel);
//Excel.SendKeys('^+{END}');
End
Else
Begin
Excel.
Range(
ExcelColIntToStr(ExcelFirstCol)+
IntToStr(ExcelFirstRow)+
':'+
ExcelColIntToStr(ExcelLastCol)+
IntToStr(ExcelLastRow)
).
Select;
End;
{
FileFormat = (xlAddIn, xlCSV, xlCSVMac, xlCSVMSDOS, xlCSVWindows, xlDBF2,
xlDBF3, xlDBF4, xlDIF, xlExcel2, xlExcel3, xlExcel4,
xlExcel4Workbook, xlIntlAddIn, xlIntlMacro, xlNormal,
xlSYLK, xlTemplate, xlText, xlTextMac, xlTextMSDOS,
xlTextWindows, xlTextPrinter, xlWK1, xlWK3, xlWKS,
xlWQ1, xlWK3FM3, xlWK1FMT, xlWK1ALL);
}
(*
//CHECKING OUT THE GARBLED OUTPUT
// Produces an *.xls
Excel.
ActiveSheet.
SaveAs(
OutFilePath+OutFileName+'02',xlCSV);
*)
// Produces an *.txt
// Excel.
// ActiveSheet.
// SaveAs(
// FullOutName,xlCSVMSDOS);
(*
// Produces nothing
Excel.
ActiveSheet.
SaveAs(
OutFilePath+OutFileName+'05',xlCSVWindows);

// Produces nothing
Excel.
ActiveSheet.
SaveAs(
OutFilePath+OutFileName+'06',xlDBF2);

// Produces an *.txt comma separated
Excel.
ActiveSheet.
SaveAs(
FullOutName,xlDBF3);
*)
// Produces an *.txt
Excel.
ActiveSheet.
SaveAs(
FullOutName,xlTextMSDOS);
(*
// Produces an *.dbf
Excel.
ActiveSheet.
SaveAs(
OutFilePath+OutFileName+'08',xlDBF4);
// Produces an *.dbf
Excel.
ActiveSheet.
SaveAs(
OutFilePath+OutFileName+'09',xlDIF);
// Produces an *.dif
Excel.
ActiveSheet.
SaveAs(
OutFilePath+OutFileName+'10',xlExcel2);
// Produces an *.slk
Excel.
ActiveSheet.
SaveAs(
OutFilePath+OutFileName+'11',xlExcel3);
// Produces an *.dbf
Excel.
ActiveSheet.
SaveAs(
OutFilePath+OutFileName+'12',xlExcel4);

*)
Result := True;
Except
Result := False;
End;
End;



{!~Saves the range on the currently active sheet
to to values only.}
Function ExcelPasteValuesOnly(
Excel : Variant;
ExcelFirstRow : Integer;
ExcelFirstCol : Integer;
ExcelLastRow : Integer;
ExcelLastCol : Integer): Boolean;
Var
RangeString : ShortString;
SheetName : ShortString;
SheetTemp : ShortString;
Begin
Result := True;
try
If ExcelVersion(Excel) = '8.0' Then
Begin
If Not ExcelSelectRange(
Excel,
ExcelFirstRow,
ExcelFirstCol,
ExcelLastRow,
ExcelLastCol)
Then
Begin
Result := False;
Msg('Unable to select the range to paste as values.');
Exit;
End;
Excel.Selection.Copy;
Excel.Selection.PasteSpecial(xlValues);
Excel.Application.CutCopyMode := False;
End
Else
Begin
Excel.Range(
ExcelColIntToStr(ExcelFirstCol)+IntToStr(ExcelFirstRow)+
':'+
ExcelColIntToStr(ExcelLastCol)+IntToStr(ExcelLastRow)).Select;
Excel.Selection.Copy;
Excel.Selection.PasteSpecial(xlValues);
Excel.Application.CutCopyMode := False;
Excel.Selection.Replace('#N/A','0');
End;
except
Msg('Unable to paste range as values');
Result := False;
end;
End;

{!~Sets a Column Width on the currently active sheet}
Function ExcelSetColumnWidth(Excel : Variant; ColNum, ColumnWidth: Integer): Boolean;
Var
RowWas : Integer;
ColWas : Integer;
Begin
Result := False;
Try
RowWas := ExcelGetRow(Excel);
ColWas := ExcelGetCol(Excel);
ExcelSelectCell(Excel,1,ColNum);
Excel.Selection.ColumnWidth := ColumnWidth;
ExcelSelectCell(Excel,RowWas,ColWas);
Result := True;
Except
Result := False;
End;
End;

{!~Selects a range on the currently active sheet}
Function ExcelSelectRange(
Excel : Variant;
FirstRow : Integer;
FirstCol : Integer;
LastRow : Integer;
LastCol : Integer): Boolean;
Var
r,c : Integer;
RowString : ShortString;
ColString : ShortString;
Begin
Result := False;
Try
If FirstRow < 1 Then Exit;
If FirstCol < 1 Then Exit;
If LastRow < 1 Then Exit;
If LastCol < 1 Then Exit;
If FirstCol > 255 Then Exit;
If LastCol > 255 Then Exit;

If Not ExcelSelectCell(
Excel,
FirstRow,
FirstCol)
Then
Begin
Exit;
End;
{Check for strange number combinations}
If FirstRow = LastRow Then
Begin
{Don't need to do anything}
End
Else
Begin
If FirstRow < LastRow Then
Begin
For r := FirstRow To LastRow - 1 Do
Begin
Excel.SendKeys('+{DOWN}');
End;
End
Else
Begin
For r := LastRow To FirstRow - 1 Do
Begin
Excel.SendKeys('+{UP}');
End;
End;
End;
If FirstCol = LastCol Then
Begin
{Don't need to do anything}
End
Else
Begin
If FirstCol < LastCol Then
Begin
For c := FirstCol To LastCol - 1 Do
Begin
Excel.SendKeys('+{RIGHT}');
End;
End
Else
Begin
For c := LastCol To FirstCol - 1 Do
Begin
Excel.SendKeys('+{LEFT}');
End;
End;
End;
Result := True;
Except
Result := False;
End;
End;

{!~Selects a range on the currently active sheet. From the
current cursor position a block is selected down and to the right.
The block proceeds down until an empty row is encountered. The
block proceeds right until an empty column is encountered.}
Function ExcelSelectBlock(
Excel : Variant;
FirstRow : Integer;
FirstCol : Integer): Boolean;
Begin
Result := False;
Try
ExcelSelectCell(Excel,FirstRow,FirstCol);
Excel.SendKeys('+{END}+{RIGHT}');
Excel.SendKeys('+{END}+{DOWN}');
Result := True;
Except
Result := False;
End;
End;

{!~Selects a range on the currently active sheet. From the
current cursor position a block is selected that contains
the currently active cell. The block proceeds in each
direction until an empty row or column is encountered.}
Function ExcelSelectBlockWhole(Excel: Variant): Boolean;
Var
FirstRow : Integer;
FirstCol : Integer;
LastRow : Integer;
LastCol : Integer;
RowWas : Integer;
ColWas : Integer;
Begin
Result := False;
Try
RowWas := ExcelGetRow(Excel);
ColWas := ExcelGetCol(Excel);

{If the base cell is on a side of the block, the block
will not be created properly.}

{View From Original Cell}
FirstRow := ExcelFirstRow(Excel);
FirstCol := ExcelFirstCol(Excel);
LastRow := ExcelLastRow(Excel);
LastCol := ExcelLastCol(Excel);
If (Not IsBlockColSide(Excel,RowWas,ColWas)) And
(Not IsBlockRowSide(Excel,RowWas,ColWas)) Then
Begin
{Cell is not on a side of the block}
ExcelSelectCell(Excel,FirstRow,FirstCol);
Excel.SendKeys('+{END}+{RIGHT}');
Excel.SendKeys('+{END}+{DOWN}');
Result := True;
Exit;
End;
{Row Only problem}
If (Not IsBlockColSide(Excel,RowWas,ColWas)) And
(IsBlockRowSide(Excel,RowWas,ColWas)) Then
Begin
{DEFAULT TO ASSUMING SELECTED CELLS ARE NEAR TOP LEFT AND
BLOCK IS TOWARD BOTTOM RIGHT}
ExcelSelectCell(Excel,RowWas,FirstCol);
Excel.SendKeys('+{END}+{RIGHT}');
Excel.SendKeys('+{END}+{DOWN}');
Result := True;
Exit;
End;
{Column Only problem}
If (IsBlockColSide(Excel,RowWas,ColWas)) And
(Not IsBlockRowSide(Excel,RowWas,ColWas)) Then
Begin
{DEFAULT TO ASSUMING SELECTED CELLS ARE NEAR TOP LEFT AND
BLOCK IS TOWARD BOTTOM RIGHT}
ExcelSelectCell(Excel,FirstRow,ColWas);
Excel.SendKeys('+{END}+{RIGHT}');
Excel.SendKeys('+{END}+{DOWN}');
Result := True;
Exit;
End;
{DEFAULT TO ASSUMING SELECTED CELLS ARE NEAR TOP LEFT AND
BLOCK IS TOWARD BOTTOM RIGHT}
ExcelSelectCell(Excel,RowWas,ColWas);
Excel.SendKeys('+{END}+{RIGHT}');
Excel.SendKeys('+{END}+{DOWN}');
Result := True;
Except
Result := False;
End;
End;

Function IsBlockColSide(Excel : Variant; RowNum, ColNum: Integer): Boolean;
Var
RowWas : Integer;
ColWas : Integer;
CellFirstSide : Integer;
CellLastSide : Integer;
FirstSideLastSide : Integer;
LastSideFirstSide : Integer;
Begin
ExcelSelectCell(Excel,RowNum,ColNum);
CellFirstSide := ExcelFirstCol(Excel);
CellLastSide := ExcelLastCol(Excel);
ExcelSelectCell(Excel,RowNum,CellFirstSide);
FirstSideLastSide := ExcelLastCol(Excel);
ExcelSelectCell(Excel,RowNum,CellLastSide);
LastSideFirstSide := ExcelFirstCol(Excel);
ExcelSelectCell(Excel,RowNum,ColNum);
If (LastSideFirstSide = ColNum) Or
(FirstSideLastSide = ColNum) Then
Begin
Result := True;
End
Else
Begin
Result := False;
End;
End;

Function IsBlockRowSide(Excel : Variant; RowNum, ColNum: Integer): Boolean;
Var
RowWas : Integer;
ColWas : Integer;
CellFirstSide : Integer;
CellLastSide : Integer;
FirstSideLastSide : Integer;
LastSideFirstSide : Integer;
Begin
ExcelSelectCell(Excel,RowNum,ColNum);
CellFirstSide := ExcelFirstRow(Excel);
CellLastSide := ExcelLastRow(Excel);
ExcelSelectCell(Excel,CellFirstSide,ColNum);
FirstSideLastSide := ExcelLastRow(Excel);
ExcelSelectCell(Excel,CellLastSide,ColNum);
LastSideFirstSide := ExcelFirstRow(Excel);
ExcelSelectCell(Excel,RowNum,ColNum);
If (LastSideFirstSide = RowNum) Or
(FirstSideLastSide = RowNum) Then
Begin
Result := True;
End
Else
Begin
Result := False;
End;
End;

{!~Renames a worksheet.}
Function ExcelRenameSheet(
Excel : Variant;
OldName : ShortString;
NewName : ShortString): Boolean;
Begin
Result := False;
Try
Excel.Sheets(OldName).Name := NewName;
Result := True;
Except
Result := False;
End;
End;

{!~Delete a WorkSheet by Name}
Function ExcelDeleteWorkSheet(
Excel : Variant;
SheetName : ShortString): Boolean;
Begin
Result := False;
Try
If Not ExcelSelectSheetByName(Excel,SheetName) Then
Begin
Msg('Could not select the '+SheetName+' WorkSheet');
Exit;
End;
Excel.ActiveWindow.SelectedSheets.Delete;
Result := True;
Finally
Result := False;
End;
End;

{!~Returns the name of the currently active worksheet as a shortstring}
Function ExcelGetActiveSheetName(Excel : Variant): ShortString;
Begin
Result := '';
Try
Result := Excel.ActiveSheet.Name;
Except
Result := '';
End;
End;

{!~Saves the range on the currently active sheet to values only.}
Function ExcelValuesOnly(
Excel : Variant;
ExcelFirstRow : Integer;
ExcelFirstCol : Integer;
ExcelLastRow : Integer;
ExcelLastCol : Integer): Boolean;
Var
r,c : Integer;
s : ShortString;
Begin
Result := False;
Try
If ExcelVersion(Excel) = '8.0' Then
Begin
For r := ExcelFirstRow To ExcelLastRow Do
Begin
For c := ExcelFirstCol To ExcelLastCol Do
Begin
s := Excel.Cells[r,c].Value;
Excel.Cells[r, c].Value := s;
End;
End;
End
Else
Begin
ExcelPasteValuesOnly(
Excel,
ExcelFirstRow,
ExcelFirstCol,
ExcelLastRow,
ExcelLastCol);
End;
Result := True;;
Except
Result := False;
End;
End;

{!~Gets the formula in a cell.}
Function ExcelGetCellFormula(
Excel : Variant;
RowNum, ColNum: Integer): ShortString;
Begin
Result := ' ';
Try
Result := Excel.
ActiveSheet.
Cells[RowNum, ColNum].
Formula;
Except
Result := ' ';
End;
End;

{!~Returns the Excel Version as a ShortString.}
Function ExcelVersion(Excel: Variant): ShortString;
Var
Version : ShortString;
Begin
Result := '';
Try
Version := Excel.Version;
Result := Version;
Except
Result := '';
End;
End;

Initialization
DelphiChecker(
RunOutsideIDE_ads,
'Advanced Delphi Systems Code',
RunOutsideIDECompany_ads,
RunOutsideIDEPhone_ads,
RunOutsideIDEDate_ads);
End.
 
代码:
既然大家都在这里将自己的东西贴出来,那我就再贴一个,将DBGrid中的文件转换到Excel中或者转换到Txt中的控件。
我自己编写的,希望大家讨论一下。
unit DBGridExport;

interface

uses
  SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Db, DBGrids, Comobj, extctrls, comctrls, ActiveX;

type
  TSpaceMark = (csComma, csSemicolon, csTab, csBlank, csEnter);

  TDBGridExport = class(TComponent)
  private
    FDB_Grid: TDBGrid;                                      {读取DBGrid的源}

    FTxtFileName: string;                                   {文本文件名}
    FSpaceMark: TSpaceMark;                                 {间隔符号}
    FSpace_Ord: Integer;                                    {间隔符号的Asc数值}
    FTitle: string;                                         {显示的标题}
    FSheetName: string;                                     {工作表标题}
    FExcel_Handle: OleVariant;                              {Excel的句柄}

    FWorkbook_Handle: OleVariant;                           {书签的句柄}

    FShow_Progress: Boolean;                                {是否显示插入进度}

    FProgress_Form: TForm;                                  {进度窗体}
    FRun_Excel_Form: TForm;                                 {启动Excel提示窗口}
    FProgressBar: TProgressBar;                             {进度条}

    function Connect_Excel: Boolean;                        {启动Excel}
    function New_Workbook: Boolean;                         {插入新的工作博}
    function InsertData_To_Excel: Boolean;                  {插入数据}
    procedure Create_ProgressForm(AOwner: TComponent);      {创建进度显示窗口}
    procedure Create_Run_Excel_Form(AOwner: TComponent);    {创建启动Excel窗口}
    procedure SetSpaceMark(Value: TSpaceMark);              {设置导出时的间隔符号}
  protected
  public
    constructor Create(AOwner: TComponent); override;       {新建}
    destructor Destroy; override;                           {销毁}
    function Export_To_Excel: Boolean; overload;            {导出到Excel中}
    function Export_To_Excel(DB_Grid: TDBGrid): Boolean; overload;

    function Export_To_Txt(NewFile: Boolean = True): Boolean; overload; {导出到文本文件中}
    function Export_To_Txt(FileName: string; NewFile: Boolean = True): Boolean; overload;
    function Export_To_Txt(DB_Grid: TDBGrid; NewFile: Boolean = True): Boolean; overload;
    function Export_To_Txt(FileName: string; DB_Grid: TDBGrid; NewFile: Boolean = True): Boolean; overload;

  published
    property DB_Grid: TDBGrid read FDB_Grid write FDB_Grid;
    property Show_Progress: Boolean read FShow_Progress write FShow_Progress;
    property TxtFileName: string read FTxtFileName write FTxtFileName;
    property SpaceMark: TSpaceMark read FSpaceMark write SetSpaceMark;
    property Title: string read FTitle write FTitle;
    property SheetName: string read FSheetName write FSheetName;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Stone', [TDBGridExport]);
end;

{-------------------------------------------------------------------------------}
{新建}
constructor TDBGridExport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FShow_Progress := True;
  FSpaceMark := csTab;
end;

{销毁}
destructor TDBGridExport.Destroy;
begin
  varClear(FExcel_Handle);
  varClear(FWorkbook_Handle);
  inherited Destroy;
end;

{===============================================================================}
{导出到文本文件中}
function TDBGridExport.Export_To_Txt(NewFile: Boolean = True): Boolean;
var
  Txt: TStrings;
  Tmp_Str: string;
  data_Str: string;
  i, j: Integer;
  Column_name: string;
  Data_Set: TDataSet;

  bookmark: pointer;
  Before_Scroll, Afrer_Scroll: TDataSetNotifyEvent;
begin
  Result := False;

  if NewFile = True then
    FTxtFileName := '';
  if FTxtFileName = '' then
  begin
    with TSaveDialog.Create(nil) do
    begin
      Title := '请选择输出文件名';
      DefaultExt := 'txt';
      Filter := '文本文件(*.Txt)|*.txt';
      Options := [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist, ofNoReadOnlyReturn, ofEnableSizing];
      if Execute then
        FTxtFileName := FileName;
      Free;
      if FTxtFileName = '' then                             {如果没有选中文件,则直接推出}
        exit;
    end;

    if FTxtFileName = '' then
    begin
      raise exception.Create('没有指定输出文件');
      Exit;
    end;

  end;

  if FDB_Grid = nil then
    raise exception.Create('请输入DBGrid名称');

  Txt := TStringList.Create;
  try
    {显示插入进度}
    if FShow_Progress = True then
    begin
      Create_ProgressForm(nil);
      FProgress_Form.Show;
    end;

    {第一行,插入标题}
    Tmp_Str := '';                                          //FDB_Grid.Columns[0].Title.Caption;
    for i := 1 to FDB_Grid.Columns.Count do
      if FDB_Grid.Columns[i - 1].Visible = True then
        Tmp_Str := Tmp_Str + FDB_Grid.Columns[i - 1].Title.Caption + Chr(FSpace_Ord);

    Tmp_Str := Copy(Tmp_Str, 1, Length(Tmp_Str) - 1);

    Txt.Add(Tmp_Str);

   {插入DBGrid中的数据}
    Data_Set := FDB_Grid.DataSource.DataSet;
   {记忆当前位置并取消任何事件}
//  new(bookmark);
    bookmark := Data_Set.GetBookmark;

    Data_Set.DisableControls;
    Before_Scroll := Data_Set.BeforeScroll;
    Afrer_Scroll := Data_Set.AfterScroll;
    Data_Set.BeforeScroll := nil;
    Data_Set.AfterScroll := nil;

    if FShow_Progress = True then
    begin
      Data_Set.Last;
      FProgress_Form.Refresh;
      FProgressBar.Max := Data_Set.RecordCount;
    end;

    {插入DBGrid中的所有字段}
    Data_Set.First;

    j := 2;
    while not Data_Set.Eof do
    begin
      if FShow_Progress = True then
        FProgressBar.Position := j - 2;

      Column_name := FDB_Grid.Columns[0].FieldName;
      Tmp_Str := '';                                        //Data_Set.FieldByName(Column_name).AsString;
      for i := 1 to FDB_Grid.Columns.Count do
        if FDB_Grid.Columns[i - 1].Visible = True then
        begin
          data_Str := FDB_Grid.Fields[i - 1].DisplayText;
          Tmp_Str := Tmp_Str + data_Str + Chr(FSpace_Ord);
        end;

      Tmp_Str := Copy(Tmp_Str, 1, Length(Tmp_Str) - 1);
      Txt.Add(Tmp_Str);

      j := j + 1;
      Data_Set.Next;
    end;

    {恢复原始事件以及标志位置}
    Data_Set.GotoBookmark(bookmark);
    Data_Set.FreeBookmark(bookmark);
//  dispose(bookmark);
    Data_Set.EnableControls;
    Data_Set.BeforeScroll := Before_Scroll;
    Data_Set.AfterScroll := Afrer_Scroll;

    {写到文件}
    Txt.SaveToFile(FTxtFileName);
    Result := True;
  finally
    Txt.Free;
    if FShow_Progress = True then
    begin
      FProgress_Form.Free;
      FProgress_Form := nil;
    end;
  end;
end;

function TDBGridExport.Export_To_Txt(FileName: string; NewFile: Boolean = True): Boolean;
begin
  FTxtFileName := FileName;
  Result := Export_To_Txt(NewFile);
end;

function TDBGridExport.Export_To_Txt(DB_Grid: TDBGrid; NewFile: Boolean = True): Boolean;
begin
  FDB_Grid := DB_Grid;
  Result := Export_To_Txt(NewFile);
end;

function TDBGridExport.Export_To_Txt(FileName: string; DB_Grid: TDBGrid; NewFile: Boolean = True): Boolean;
begin
  FTxtFileName := FileName;
  FDB_Grid := DB_Grid;
  Result := Export_To_Txt(NewFile);
end;

{-------------------------------------------------------------------------------}
{设置导出时的间隔符号}
procedure TDBGridExport.SetSpaceMark(Value: TSpaceMark);
begin
  FSpaceMark := Value;
  case Value of
    csComma: FSpace_Ord := ord(',');
    csSemicolon: FSpace_Ord := ord(';');
    csTab: FSpace_Ord := 9;
    csBlank: FSpace_Ord := 32;
    csEnter: FSpace_Ord := 13;
  end;
end;


{===============================================================================}
{导出到Excel中}
function TDBGridExport.Export_To_Excel: Boolean;
begin
  if FDB_Grid = nil then
    raise exception.Create('请输入DBGrid名称');

  Result := False;
  if Connect_Excel = True then
    if New_Workbook = True then
      if InsertData_To_Excel = True then
        Result := True;
end;

function TDBGridExport.Export_To_Excel(DB_Grid: TDBGrid): Boolean;
begin
  FDB_Grid := DB_Grid;
  Result := Export_To_Excel;
end;


{-------------------------------------------------------------------------------}
{启动Excel}
function TDBGridExport.Connect_Excel: Boolean;
  {连接Ole对象}
  function My_GetActiveOleObject(const ClassName: string; out Ole_Handle: IDispatch): Boolean;
  var                                                       //IDispatch
    ClassID: TCLSID;
    Unknown: IUnknown;
    l_Result: HResult;
  begin
    Result := False;

    l_Result := CLSIDFromProgID(PWideChar(WideString(ClassName)), ClassID);
    if (l_Result and $80000000) = 0 then
    begin
      l_Result := GetActiveObject(ClassID, nil, Unknown);
      if (l_Result and $80000000) = 0 then
      begin
        l_Result := Unknown.QueryInterface(IDispatch, Ole_Handle);
        if (l_Result and $80000000) = 0 then
          Result := True;
      end;
    end;
  end;

  {创建OLE对象}
  function My_CreateOleObject(const ClassName: string; out Ole_Handle: IDispatch): Boolean;
  var
    ClassID: TCLSID;
    l_Result: HResult;
  begin
    Result := False;

    l_Result := CLSIDFromProgID(PWideChar(WideString(ClassName)), ClassID);
    if (l_Result and $80000000) = 0 then
    begin
      l_Result := CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
        CLSCTX_LOCAL_SERVER, IDispatch, Ole_Handle);
      if (l_Result and $80000000) = 0 then
        Result := True;
    end;
  end;

var
  l_Excel_Handle: IDispatch;
begin
  if FShow_Progress = True then
  begin
    Create_Run_Excel_Form(nil);
    FRun_Excel_Form.Show;
  end;

  if My_GetActiveOleObject('Excel.Application', l_Excel_Handle) = False then
    if My_CreateOleObject('Excel.Application', l_Excel_Handle) = False then
    begin
      FRun_Excel_Form.Free;
      FRun_Excel_Form := nil;

      raise exception.Create('启动Excel失败,可能没有安装Excel!');
      Result := False;
      Exit;
    end;
  FExcel_Handle := l_Excel_Handle;

  if FShow_Progress = True then
  begin
    FRun_Excel_Form.Free;
    FRun_Excel_Form := nil;
  end;
  Result := True;
end;

{插入新的工作博}
function TDBGridExport.New_Workbook: Boolean;
var
  i: Integer;
begin
  Result := True;
  try
    FWorkbook_Handle := FExcel_Handle.Workbooks.Add;
  except
    raise exception.Create('新建Excel工作表出错!');
    Result := False;
    Exit;
  end;

  if FTitle <> '' then
    FWorkbook_Handle.Application.ActiveWindow.Caption := FTitle;
  if FSheetName <> '' then
  begin
    for i := 2 to FWorkbook_Handle.Sheets.Count do
      if FSheetName = FWorkbook_Handle.Sheets[i].Name then
      begin
        raise exception.Create('工作表命名重复!');
        Result := False;
        exit;
      end;
    try
      FWorkbook_Handle.Sheets[1].Name := FSheetName;
    except
      raise exception.Create('工作表命名错误!');
      Result := False;
      exit;
    end;
  end;
end;

{插入数据}
function TDBGridExport.InsertData_To_Excel: Boolean;
var
  i, j, k: Integer;
  data_Str: string;
  Column_name: string;
  Data_Set: TDataSet;

  bookmark: pointer;
  Before_Scroll, Afrer_Scroll: TDataSetNotifyEvent;
begin
  try
    {显示插入进度}
    if FShow_Progress = True then
    begin
      Create_ProgressForm(nil);
      FProgress_Form.Show;
    end;

    {第一行,插入标题}{仅仅插入可见数据}
    j := 1;
    for i := 1 to FDB_Grid.Columns.Count do
      if FDB_Grid.Columns[i - 1].Visible = True then
      begin
        FWorkbook_Handle.WorkSheets[1].Cells[1, j].Value := FDB_Grid.Columns[i - 1].Title.Caption;
        FWorkbook_Handle.WorkSheets[1].Columns[j].ColumnWidth := FDB_Grid.Columns[i - 1].Width div 6;
        j := j + 1
      end;

   {插入DBGrid中的数据}
    Data_Set := FDB_Grid.DataSource.DataSet;
   {记忆当前位置并取消任何事件}
//  new(bookmark);
    bookmark := Data_Set.GetBookmark;

    Data_Set.DisableControls;
    Before_Scroll := Data_Set.BeforeScroll;
    Afrer_Scroll := Data_Set.AfterScroll;
    Data_Set.BeforeScroll := nil;
    Data_Set.AfterScroll := nil;

    if FShow_Progress = True then
    begin
      Data_Set.Last;
      FProgress_Form.Refresh;
      FProgressBar.Max := Data_Set.RecordCount;
    end;

    Data_Set.First;

    k := 2;
    while not Data_Set.Eof do
    begin
      if FShow_Progress = True then
        FProgressBar.Position := k;

      j := 1;
      for i := 1 to FDB_Grid.Columns.Count do
      begin
        if FDB_Grid.Columns[i - 1].Visible = True then
        begin
          Column_name := FDB_Grid.Columns[i - 1].FieldName;
          data_Str := FDB_Grid.Fields[i - 1].DisplayText;
          FWorkbook_Handle.WorkSheets[1].Cells[k, j].Value := data_Str;
          j := j + 1;
        end;
      end;
      k := k + 1;
      Data_Set.Next;
    end;

    {恢复原始事件以及标志位置}
    Data_Set.GotoBookmark(bookmark);
    Data_Set.FreeBookmark(bookmark);
//  dispose(bookmark);
    Data_Set.EnableControls;
    Data_Set.BeforeScroll := Before_Scroll;
    Data_Set.AfterScroll := Afrer_Scroll;

    Result := True;
  finally
    FExcel_Handle.Visible := True;
    FExcel_Handle.Application.ScreenUpdating := True;

    if FShow_Progress = True then
    begin
      FProgress_Form.Free;
      FProgress_Form := nil;
    end;
  end;
end;

{===============================================================================}
{启动Excel时给出进度显示}
procedure TDBGridExport.Create_Run_Excel_Form(AOwner: TComponent);
var
  Panel: TPanel;
  Prompt: TLabel;                                           {提示的标签}
begin
  if assigned(FRun_Excel_Form) then exit;

  FRun_Excel_Form := TForm.Create(AOwner);
  with FRun_Excel_Form do
  begin
    try
      Font.Name := '宋体';                                  {设置字体}
      Font.Size := 9;
      BorderStyle := bsNone;
      Width := 300;
      Height := 100;
      BorderWidth := 2;
      Color := clBlue;
      Position := poScreenCenter;

      Panel := TPanel.Create(FRun_Excel_Form);
      with Panel do
      begin
        Parent := FRun_Excel_Form;
        Align := alClient;
        BevelInner := bvNone;
        BevelOuter := bvRaised;
        Caption := '';
      end;

      Prompt := TLabel.Create(Panel);
      with Prompt do
      begin
        Parent := panel;
        AutoSize := True;
        Left := 25;
        Top := 25;
        Caption := '正在导出数据,请稍候……';
      end;
    except
    end;
  end;
end;


{===============================================================================}
{创建进度显示窗口}
procedure TDBGridExport.Create_ProgressForm(AOwner: TComponent);
var
  Panel: TPanel;
  Prompt: TLabel;                                           {提示的标签}
begin
  if assigned(FProgress_Form) then exit;

  FProgress_Form := TForm.Create(AOwner);
  with FProgress_Form do
  begin
    try
      Font.Name := '宋体';                                  {设置字体}
      Font.Size := 9;
      BorderStyle := bsNone;
      Width := 300;
      Height := 100;
      BorderWidth := 2;
      Color := clBlue;
      Position := poScreenCenter;
      Panel := TPanel.Create(FProgress_Form);
      with Panel do
      begin
        Parent := FProgress_Form;
        Align := alClient;
        BevelInner := bvNone;
        BevelOuter := bvRaised;
        Caption := '';
      end;

      Prompt := TLabel.Create(Panel);
      with Prompt do
      begin
        Parent := panel;
        AutoSize := True;
        Left := 25;
        Top := 25;
        Caption := '正在导出数据,请稍候……';
      end;

      FProgressBar := TProgressBar.Create(panel);
      with FProgressBar do
      begin
        Parent := panel;
        Left := 20;
        Top := 50;
        Height := 18;
        Width := 260;
      end;
    except
    end;
  end;
end;


end.
 
听君一席话,胜读十年书![^]
 
如何取消Word2000中的宏病毒提示

Word采用了宏作为其字处理系统的补充,是用户能够自己编写一部分代码来实现自己特定
的功能,大大方便了其他系统和Word之间的连接,但是同时也带来了负面的问题,人们可
以编写一些恶意的代码,危害系统的安全,从台湾No.1病毒开始到现在的美丽沙病毒,无
一不对系统造成一定危害。
为了避免这个缺点,微软提供了防病毒防护的功能,在Word97的《工具》->《选项》->《常规》
中有宏病毒防护的选项,在Word2000提供了高、中、低三种宏病毒安全级别。在Word97中
可以使用Options.VirusProtection = False来取消宏病毒防护,这样就给宏病毒提供了
机会,只要你运行过一个宏病毒,它就自动将宏病毒防护关闭,因此防护宏病毒的能力
不是太强。
在Word2000中,微软提供了宏认证的解决方案,根据证书认证机制来实现,如果宏不含有数字
签名整数,那么如果安全级别设置为高,则直接禁用宏,如果安全级别是中,则提示用户是否
启用宏,如果安全级别是无,则任何宏都能够能够运行了。
如果宏提供了认证证书,则Word将检查认证证书,判断其有效性,并提示用户是否接受该证书,
如果用户接受了该证书,则以后就不再显示使用该证书签名的宏警告。

现在问题出来了,我们自己编写的宏,如何进行认证呢?怎么进行认证呢?
通常人们会去找宏病毒安全性里面,但是在它的可靠来源列表中就是不能添加,只能删除,那么
从那里添加呢?
其实,Word提供了添加的途径,就是在Word的Visual Basic编辑器里面《工具》->《数字签名》,
选择相应证书即可.但是问题又有了,如何能够添加证书呢,通常我们打开的时候发觉可选择证书
空空的。
有两种途径可以解决这个问题,一是向证书颁发机构申请数字签名,申请的时候选择用途为代码的
数字签名就可以了,然后安装上申请下来的Cer文件直接安装就可以了,但是在打开含有此数字签
名的宏的时候,计算机必须和证书办法机构联网,否则会提示证书无效.
另一种途径是自己创建证书,Word2000提供了一个自己进行数字签名的工具:SelfCert.exe,路径
为《Office安装路径》/Office/SELFCERT.EXE,运行此文件,输入名字即可产生。
至此我们可以生成证书了,也就可以进行数字签名了。
 
就这些了!到今天为止,将我摸索Ole的所有心得都写出来了。供大家讨论吧。
帖子太长了,打开速度慢了许多。[:)]
 
这页的好资料真多,我也跟贴在这里吧。

Delphi 5 控制Excel

作者:吴晓勇,孙唏瑜
时间:2001年11月20日

(一) 使用动态创建的方法

首先创建 Excel 对象,使用ComObj:
var ExcelApp: Variant;
ExcelApp := CreateOleObject( 'Excel.Application' );

1) 显示当前窗口:
ExcelApp.Visible := True;

2) 更改 Excel 标题栏:
ExcelApp.Caption := '应用程序调用 Microsoft Excel';

3) 添加新工作簿:
ExcelApp.WorkBooks.Add;

4) 打开已存在的工作簿:
ExcelApp.WorkBooks.Open( 'C:/Excel/Demo.xls' );

5) 设置第2个工作表为活动工作表:
ExcelApp.WorkSheets[2].Activate;

ExcelApp.WorksSheets[ 'Sheet2' ].Activate;

6) 给单元格赋值:
ExcelApp.Cells[1,4].Value := '第一行第四列';

7) 设置指定列的宽度(单位:字符个数),以第一列为例:
ExcelApp.ActiveSheet.Columns[1].ColumnsWidth := 5;

8) 设置指定行的高度(单位:磅)(1磅=0.035厘米),以第二行为例:
ExcelApp.ActiveSheet.Rows[2].RowHeight := 1/0.035; // 1厘米

9) 在第8行之前插入分页符:
ExcelApp.WorkSheets[1].Rows.PageBreak := 1;

10) 在第8列之前删除分页符:
ExcelApp.ActiveSheet.Columns[4].PageBreak := 0;

11) 指定边框线宽度:
ExcelApp.ActiveSheet.Range[ 'B3:D4' ].Borders[2].Weight := 3;
1-左 2-右 3-顶 4-底 5-斜( / ) 6-斜( / )

12) 清除第一行第四列单元格公式:
ExcelApp.ActiveSheet.Cells[1,4].ClearContents;

13) 设置第一行字体属性:
ExcelApp.ActiveSheet.Rows[1].Font.Name := '隶书';
ExcelApp.ActiveSheet.Rows[1].Font.Color := clBlue;
ExcelApp.ActiveSheet.Rows[1].Font.Bold := True;
ExcelApp.ActiveSheet.Rows[1].Font.UnderLine := True;

14) 进行页面设置:

a.页眉:
ExcelApp.ActiveSheet.PageSetup.CenterHeader := '报表演示';
b.页脚:
ExcelApp.ActiveSheet.PageSetup.CenterFooter := '第&P页';
c.页眉到顶端边距2cm:
ExcelApp.ActiveSheet.PageSetup.HeaderMargin := 2/0.035;
d.页脚到底端边距3cm:
ExcelApp.ActiveSheet.PageSetup.HeaderMargin := 3/0.035;
e.顶边距2cm:
ExcelApp.ActiveSheet.PageSetup.TopMargin := 2/0.035;
f.底边距2cm:
ExcelApp.ActiveSheet.PageSetup.BottomMargin := 2/0.035;
g.左边距2cm:
ExcelApp.ActiveSheet.PageSetup.LeftMargin := 2/0.035;
h.右边距2cm:
ExcelApp.ActiveSheet.PageSetup.RightMargin := 2/0.035;
i.页面水平居中:
ExcelApp.ActiveSheet.PageSetup.CenterHorizontally := 2/0.035;
j.页面垂直居中:
ExcelApp.ActiveSheet.PageSetup.CenterVertically := 2/0.035;
k.打印单元格网线:
ExcelApp.ActiveSheet.PageSetup.PrintGridLines := True;

15) 拷贝操作:

a.拷贝整个工作表:
ExcelApp.ActiveSheet.Used.Range.Copy;
b.拷贝指定区域:
ExcelApp.ActiveSheet.Range[ 'A1:E2' ].Copy;
c.从A1位置开始粘贴:
ExcelApp.ActiveSheet.Range.[ 'A1' ].PasteSpecial;
d.从文件尾部开始粘贴:
ExcelApp.ActiveSheet.Range.PasteSpecial;

16) 插入一行或一列:
a. ExcelApp.ActiveSheet.Rows[2].Insert;
b. ExcelApp.ActiveSheet.Columns[1].Insert;

17) 删除一行或一列:
a. ExcelApp.ActiveSheet.Rows[2].Delete;
b. ExcelApp.ActiveSheet.Columns[1].Delete;

18) 打印预览工作表:
ExcelApp.ActiveSheet.PrintPreview;

19) 打印输出工作表:
ExcelApp.ActiveSheet.PrintOut;

20) 工作表保存:
if not ExcelApp.ActiveWorkBook.Saved then
ExcelApp.ActiveSheet.PrintPreview;

21) 工作表另存为:
ExcelApp.SaveAs( 'C:/Excel/Demo1.xls' );

22) 放弃存盘:
ExcelApp.ActiveWorkBook.Saved := True;

23) 关闭工作簿:
ExcelApp.WorkBooks.Close;

24) 退出 Excel:
ExcelApp.Quit;

(二) 使用Delphi 控件方法
在Form中分别放入ExcelApplication, ExcelWorkbook和ExcelWorksheet。

1) 打开Excel
ExcelApplication1.Connect;

2) 显示当前窗口:
ExcelApplication1.Visible[0]:=True;

3) 更改 Excel 标题栏:
ExcelApplication1.Caption := '应用程序调用 Microsoft Excel';

4) 添加新工作簿:
ExcelWorkbook1.ConnectTo(ExcelApplication1.Workbooks.Add(EmptyParam,0));

5) 添加新工作表:
var Temp_Worksheet: _WorkSheet;
begin
Temp_Worksheet:=ExcelWorkbook1.
WorkSheets.Add(EmptyParam,EmptyParam,EmptyParam,EmptyParam,0) as _WorkSheet;
ExcelWorkSheet1.ConnectTo(Temp_WorkSheet);
End;

6) 打开已存在的工作簿:
ExcelApplication1.Workbooks.Open (c:/a.xls
EmptyParam,EmptyParam,EmptyParam,EmptyParam,
EmptyParam,EmptyParam,EmptyParam,EmptyParam,
EmptyParam,EmptyParam,EmptyParam,EmptyParam,0)

7) 设置第2个工作表为活动工作表:
ExcelApplication1.WorkSheets[2].Activate; 或
ExcelApplication1.WorksSheets[ 'Sheet2' ].Activate;

8) 给单元格赋值:
ExcelApplication1.Cells[1,4].Value := '第一行第四列';

9) 设置指定列的宽度(单位:字符个数),以第一列为例:
ExcelApplication1.ActiveSheet.Columns[1].ColumnsWidth := 5;

10) 设置指定行的高度(单位:磅)(1磅=0.035厘米),以第二行为例:
ExcelApplication1.ActiveSheet.Rows[2].RowHeight := 1/0.035; // 1厘米

11) 在第8行之前插入分页符:
ExcelApplication1.WorkSheets[1].Rows.PageBreak := 1;

12) 在第8列之前删除分页符:
ExcelApplication1.ActiveSheet.Columns[4].PageBreak := 0;

13) 指定边框线宽度:
ExcelApplication1.ActiveSheet.Range[ 'B3:D4' ].Borders[2].Weight := 3;
1-左 2-右 3-顶 4-底 5-斜( / ) 6-斜( / )

14) 清除第一行第四列单元格公式:
ExcelApplication1.ActiveSheet.Cells[1,4].ClearContents;

15) 设置第一行字体属性:
ExcelApplication1.ActiveSheet.Rows[1].Font.Name := '隶书';
ExcelApplication1.ActiveSheet.Rows[1].Font.Color := clBlue;
ExcelApplication1.ActiveSheet.Rows[1].Font.Bold := True;
ExcelApplication1.ActiveSheet.Rows[1].Font.UnderLine := True;

16) 进行页面设置:
a.页眉:
ExcelApplication1.ActiveSheet.PageSetup.CenterHeader := '报表演示';
b.页脚:
ExcelApplication1.ActiveSheet.PageSetup.CenterFooter := '第&P页';
c.页眉到顶端边距2cm:
ExcelApplication1.ActiveSheet.PageSetup.HeaderMargin := 2/0.035;
d.页脚到底端边距3cm:
ExcelApplication1.ActiveSheet.PageSetup.HeaderMargin := 3/0.035;
e.顶边距2cm:
ExcelApplication1.ActiveSheet.PageSetup.TopMargin := 2/0.035;
f.底边距2cm:
ExcelApplication1.ActiveSheet.PageSetup.BottomMargin := 2/0.035;
g.左边距2cm:
ExcelApplication1.ActiveSheet.PageSetup.LeftMargin := 2/0.035;
h.右边距2cm:
ExcelApplication1.ActiveSheet.PageSetup.RightMargin := 2/0.035;
i.页面水平居中:
ExcelApplication1.ActiveSheet.PageSetup.CenterHorizontally := 2/0.035;
j.页面垂直居中:
ExcelApplication1.ActiveSheet.PageSetup.CenterVertically := 2/0.035;
k.打印单元格网线:
ExcelApplication1.ActiveSheet.PageSetup.PrintGridLines := True;

17) 拷贝操作:

a.拷贝整个工作表:
ExcelApplication1.ActiveSheet.Used.Range.Copy;

b.拷贝指定区域:
ExcelApplication1.ActiveSheet.Range[ 'A1:E2' ].Copy;

c.从A1位置开始粘贴:
ExcelApplication1.ActiveSheet.Range.[ 'A1' ].PasteSpecial;

d.从文件尾部开始粘贴:
ExcelApplication1.ActiveSheet.Range.PasteSpecial;

18) 插入一行或一列:
a. ExcelApplication1.ActiveSheet.Rows[2].Insert;
b. ExcelApplication1.ActiveSheet.Columns[1].Insert;

19) 删除一行或一列:
a. ExcelApplication1.ActiveSheet.Rows[2].Delete;
b. ExcelApplication1.ActiveSheet.Columns[1].Delete;

20) 打印预览工作表:
ExcelApplication1.ActiveSheet.PrintPreview;

21) 打印输出工作表:
ExcelApplication1.ActiveSheet.PrintOut;

22) 工作表保存:
if not ExcelApplication1.ActiveWorkBook.Saved then
ExcelApplication1.ActiveSheet.PrintPreview;

23) 工作表另存为:
ExcelApplication1.SaveAs( 'C:/Excel/Demo1.xls' );

24) 放弃存盘:
ExcelApplication1.ActiveWorkBook.Saved := True;

25) 关闭工作簿:
ExcelApplication1.WorkBooks.Close;

26) 退出 Excel:
ExcelApplication1.Quit;
ExcelApplication1.Disconnect;

(三) 使用Delphi 控制Excle二维图
在Form中分别放入ExcelApplication, ExcelWorkbook和ExcelWorksheet
var asheet1,achart, range:variant;

1)选择当第一个工作薄第一个工作表
asheet1:=ExcelApplication1.Workbooks[1].Worksheets[1];

2)增加一个二维图
achart:=asheet1.chartobjects.add(100,100,200,200);

3)选择二维图的形态
achart.chart.charttype:=4;

4)给二维图赋值
series:=achart.chart.seriescollection;
range:=sheet1!r2c3:r3c9;
series.add(range,true);

5)加上二维图的标题
achart.Chart.HasTitle:=True;
achart.Chart.ChartTitle.Characters.Text:=’ Excle二维图’

6)改变二维图的标题字体大小
achart.Chart.ChartTitle.Font.size:=6;

7)给二维图加下标说明
achart.Chart.Axes(xlCategory, xlPrimary).HasTitle := True;
achart.Chart.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text := '下标说明';

8)给二维图加左标说明
achart.Chart.Axes(xlValue, xlPrimary).HasTitle := True;
achart.Chart.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text := '左标说明';

9)给二维图加右标说明
achart.Chart.Axes(xlValue, xlSecondary).HasTitle := True;
achart.Chart.Axes(xlValue, xlSecondary).AxisTitle.Characters.Text := '右标说明';

10)改变二维图的显示区大小
achart.Chart.PlotArea.Left := 5;
achart.Chart.PlotArea.Width := 223;
achart.Chart.PlotArea.Height := 108;

11)给二维图坐标轴加上说明
achart.chart.seriescollection[1].NAME:='坐标轴说明';

E-Mail: sunxiyu@gd-soft.net
wuxy@gd-soft.net

声明:转载本文内容请与作者联系。
 
RE:yzhshi
其实对于技术问题,我从大富翁得到了许多,尤其是hubdog的葵花宝典,我也希望贡献自己
的一份力量,众人拾柴火焰高!
请问能不能把“hubdog的葵花宝典”贴在这里,让我们能一次性的打印出来?
 
to sandy suen:
hubdog的葵花宝典类似于一个帮助,没办法贴的。很多地方有下载
 
后退
顶部