{通用 数据导出过程 }
procedure TDmFrm.OutputcxGrid(mycxGrid: TcxGrid);
var
SFD: TSaveDialog;
FileName, FileExt: string;
begin
SFD := TSaveDialog.Create(nil);
try
SFD.Filter := 'Excel文件 (.xls)|.xls|XML文件 (.xml)|.xml|文本文件 (.txt)|.txt|网页文件 (.html)|.html';
SFD.Title := '导出为';
SFD.DefaultExt := '.XLS';
SFD.Options := [ofOverwritePrompt, ofEnableSizing];
if not SFD.Execute then Exit;
FileName := SFD.FileName;
FileExt := UpperCase(ExtractFileExt(FileName));
if FileExt = '.XLS' then
ExportGridToExcel(FileName, mycxGrid, True, True)
else
if FileExt = '.XML' then
ExportGridToHTML(FileName, mycxGrid, True, True)
else
if FileExt = '.TXT' then
ExportGridToText(FileName, mycxGrid, True, True)
else
if FileExt = '.HTML' then
ExportGridToHTML(FileName, mycxGrid, True, True)
else
begin
Application.MessageBox('不支持的导出格式', 'xx');
Exit;
end;
Application.MessageBox('导出数据成功！', '提示');
finally
SFD.Free;
end;
end;
{*------------------------------------------------------------------------------
工作本执行程序 文件路径 @return 返回exe的路径，以‘\’结束的
-------------------------------------------------------------------------------}
function TDmFrm.GetPath: string;
begin
Result := ExtractFilePath(ParamStr(0));
if Result[Length(Result)] <> '' then Result := Result + '';
end;
{建立 ftp连接}
function OpenFtp: Boolean;
Var MyFtp: TWLFtp;
begin
Result := False;
try
MyFtp := TWLFtp.Create;
MyFtp.Host := .FtpServer;
MyFtp.Port := StrToInt(.FtpPort);
MyFtp.UserName := .FtpUser;
MyFtp.Password := UncrypKey(.FtpPass);
except
Exit;
end;
if MyFtp.Connect then
Result := True;
end;
{建立 一个通用查询函数}
function OpenAdoquery(TheAqry: TADOQuery; mSql: string): Boolean;
begin
try
with TheAqry do
begin
Close;
SQL.Clear;
SQL.Add(mSql);
Open;
First;
end;
Result := True;
except
Result := False;
end;
end;
{一个通用 执行 SQL语句函数}
function TDmFrm.ExecAdoquery(TheAqry: TADOQuery; m_Sql: string): Boolean;
begin
try
with TheAqry do
begin
Close;
SQL.Clear;
SQL.Add(m_Sql);
ExecSQL;
Result := True;
end;
except
Result := False;
end;
end;
//-------------------------------------------------------------------------
// 文件名：WLFtp.pas
// 描述：封装Ftp API函数，实现上传，下载文件，创建目录
//
// 类名：TWLFtp
// 作者：Win Lai
// 创建日期：2004-1-9
// 修改日期：2004-1-11
//-------------------------------------------------------------------------
unit uWLFtp;
interface
uses
Windows, Messages, Variants, SysUtils, Classes, Wininet, Dialogs;
type
TWLFtp = class(TObject)
private
FInetHandle: HInternet; // 句柄
FFtpHandle: HInternet; // 句柄
FHost: string; // 主机IP地址
FUserName: string; // 用户名
FPassword: string; // 密码
FPort: Integer; // 端口
FCurrentDir: string; // 当前目录
public
constructor Create; virtual;
destructor Destroy; override;
function Connect: Boolean;
function Disconnect: Boolean;
function UploadFile(RemoteFile: PChar; NewFile: PChar): Boolean;
function DownloadFile(RemoteFile: PChar; NewFile: PChar): Boolean;
function DeleteFtpFile(RemoteFileName: PChar): Boolean;
function CreateDirectory(Directory: PChar): Boolean;
function LayerNumber(dir: string): Integer;
function MakeDirectory(dir: string): Boolean;
function FTPMakeDirectory(dir: string): Boolean;
function IndexOfLayer(index: Integer; dir: string): string;
function GetFileName(FileName: string): string;
function GetDirectory(dir: string): string;
property InetHandle: HInternet read FInetHandle write FInetHandle;
property FtpHandle: HInternet read FFtpHandle write FFtpHandle;
property Host: string read FHost write FHost;
property UserName: string read FUserName write FUserName;
property Password: string read FPassword write FPassword;
property Port: Integer read FPort write FPort;
property CurrentDir: string read FCurrentDir write FCurrentDir;
end;
implementation
//-------------------------------------------------------------------------
// 构造函数
constructor TWLFtp.Create;
begin
inherited Create;
end;
//-------------------------------------------------------------------------
// 析构函数
destructor TWLFtp.Destroy;
begin
inherited Destroy;
end;
//-------------------------------------------------------------------------
// 链接服务器
function TWLFtp.Connect: Boolean;
begin
try
Result := False;
// 创建句柄
FInetHandle := InternetOpen(PChar('KOLFTP'), 0, nil, nil, 0);
FtpHandle := InternetConnect(FInetHandle, PChar(Host), FPort, PChar(FUserName),
PChar(FPassword), INTERNET_SERVICE_FTP, 0, 255);
if Assigned(FtpHandle) then
begin
Result := True;
end;
except
Result := False;
end;
end;
//-------------------------------------------------------------------------
// 断开链接
function TWLFtp.Disconnect: Boolean;
begin
try
InternetCloseHandle(FFtpHandle);
InternetCloseHandle(FInetHandle);
FtpHandle := nil;
InetHandle := nil;
Result := True;
except
Result := False;
end;
end;
//-------------------------------------------------------------------------
// 上传文件
function TWLFtp.UploadFile(RemoteFile: PChar; NewFile: PChar): Boolean;
begin
try
Result := True;
FTPMakeDirectory(NewFile);
if not FtpPutFile(FFtpHandle, RemoteFile, NewFile,
FTP_TRANSFER_TYPE_BINARY, 255) then
begin
Result := False;
end;
except
Result := False;
end;
end;
//删除文件
function TWLFtp.DeleteFtpFile(RemoteFileName: PChar): Boolean;
begin
try
Result := True;
if not FtpDeleteFile(FFtpHandle, RemoteFileName) then
begin
Result := False;
end;
except
Result := False;
end;
end;
//-------------------------------------------------------------------------
// 下载文件
function TWLFtp.DownloadFile(RemoteFile: PChar; NewFile: PChar): Boolean;
begin
try
Result := True;
MakeDirectory(NewFile);
if not FtpGetFile(FFtpHandle, RemoteFile, NewFile,
True, FILE_ATTRIBUTE_NORMAL, FTP_TRANSFER_TYPE_BINARY or INTERNET_FLAG_RELOAD, 255) then
begin
Result := False;
end;
except
Result := False;
end;
end;
//-------------------------------------------------------------------------
// 创建目录
function TWLFtp.CreateDirectory(Directory: PChar): Boolean;
begin
try
Result := True;
if FtpCreateDirectory(FFtpHandle, Directory) = False then
begin
Result := False;
end;
except
Result := False;
end;
end;
//-------------------------------------------------------------------------
// 目录数
function TWLFtp.LayerNumber(dir: string): Integer;
var
i: Integer;
flag: string;
begin
Result := 0;
for i := 1 to Length(dir) do
begin
flag := Copy(dir, i, 1);
if (flag = '') or (flag = '/') then
begin
Result := Result + 1;
end;
end;
end;
//-------------------------------------------------------------------------
// 创建目录
function TWLFtp.FTPMakeDirectory(dir: string): Boolean;
var
Count, i: Integer;
SubPath: string;
begin
Result := True;
Count := LayerNumber(dir);
for i := 1 to Count do
begin
SubPath := IndexOfLayer(i, dir);
if CreateDirectory(PChar(CurrentDir + SubPath)) = False then
begin
Result := False;
end;
end;
end;
//-------------------------------------------------------------------------
// 创建目录
function TWLFtp.MakeDirectory(dir: string): Boolean;
var
Count, i: Integer;
SubPath: string;
Str: string;
begin
Result := True;
Count := LayerNumber(dir);
Str := GetDirectory(dir);
for i := 2 to Count do
begin
SubPath := IndexOfLayer(i, Str);
if not DirectoryExists(SubPath) then
begin
if not CreateDir(SubPath) then
begin
Result := False;
end;
end;
end;
end;
//-------------------------------------------------------------------------
// 获取index层的目录
function TWLFtp.IndexOfLayer(index: Integer; dir: string): string;
var
Count, i: Integer;
ch: string;
begin
Result := '';
Count := 0;
for i := 1 to Length(dir) do
begin
ch := Copy(dir, i, 1);
if (ch = '') or (ch = '/') then
begin
Count := Count + 1;
end;
if Count = index then
begin
Break;
end;
Result := Result + ch;
end;
end;
//-------------------------------------------------------------------------
// 获取文件名
function TWLFtp.GetFileName(FileName: string): string;
begin
Result := '';
while (Copy(FileName, Length(FileName), 1) <> '') and (Length(FileName) > 0) do
begin
Result := Copy(FileName, Length(FileName), 1) + Result;
Delete(FileName, Length(FileName), 1);
end;
end;
//-------------------------------------------------------------------------
// 获取目录
function TWLFtp.GetDirectory(dir: string): string;
begin
Result := dir;
while (Copy(Result, Length(Result), 1) <> '') and (Length(Result) > 0) do
begin
Delete(Result, Length(Result), 1);
end;
{ if Copy(Result, Length), 1)='' then
begin
Delete(Result, 1, 1);
end;}
end;
//-------------------------------------------------------------------------
end.
//串加密或解密函数
unit FunctionPas;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
const
LockKey: Word = 13;
BegKey: Integer = 53523;
EndKey: Integer = 32768;
type
TCPUID = array[1..4] of Longint;
TVendor = array[0..11] of char;
function TransChar(AChar: char): Integer;
function StrToHex(AStr: string): string;
function HexToStr(AStr: string): string;
function EncrypKey(const S: string): string;
function UncrypKey(const S: string): string;
implementation
function EncrypKey(const S: string): string;
var
i: Integer;
Key: Word;
begin
Result := S;
Key := LockKey;
for i := 1 to Length(S) do
begin
Result[i] := char(Byte(S[i]) xor (Key shr 8));
Key := (Byte(Result[i]) + Key) * BegKey + EndKey;
if Result[i] = Chr(0) then
Result[i] := S[i];
end;
Result := StrToHex(Result);
end;
function UncrypKey(const S: string): string;
var
i: Integer;
Key: Word;
S1: string;
begin
Key := LockKey;
S1 := HexToStr(S);
Result := S1;
for i := 1 to Length(S1) do
begin
if char(Byte(S1[i]) xor (Key shr 8)) = Chr(0) then
begin
Result[i] := S1[i];
Key := (Byte(Chr(0)) + Key) * BegKey + EndKey;
end
else begin
Result[i] := char(Byte(S1[i]) xor (Key shr 8));
Key := (Byte(S1[i]) + Key) * BegKey + EndKey;
end;
end;
end;
function TransChar(AChar: char): Integer;
begin
if AChar in ['0'..'9'] then
Result := Ord(AChar) - Ord('0')
else
Result := 10 + Ord(AChar) - Ord('A');
end;
function StrToHex(AStr: string): string;
var
i: Integer;
begin
Result := '';
for i := 1 to Length(AStr) do
Result := Result + IntToHex(Byte(AStr[i]), 2);
end;
function HexToStr(AStr: string): string;
var
i: Integer;
CharValue: Word;
begin
Result := '';
for i := 1 to Trunc(Length(AStr) / 2) do
begin
Result := Result + ' ';
CharValue := TransChar(AStr[2 * i - 1]) * 16 + TransChar(AStr[2 * i]);
Result[i] := char(CharValue);
end;
end;
end.
Uses
DBGridEhImpExp, DBGridEhGrouping, DBGridEhToolCtrls,
procedure Tfrm_zcmain.XLS1Click(Sender : TObject);
var
ExpClass:TDBGridEhExportClass;
Ext:String;
begin
SaveDialog1.FileName := 'file1';
if (ActiveControl is TDBGridEh) then
if SaveDialog1.Execute then
begin
case SaveDialog1.FilterIndex of
1: begin ExpClass := TDBGridEhExportAsText; Ext := 'txt'; end;
2: begin ExpClass := TDBGridEhExportAsCSV; Ext := 'csv'; end;
3: begin ExpClass := TDBGridEhExportAsHTML; Ext := 'htm'; end;
4: begin ExpClass := TDBGridEhExportAsRTF; Ext := 'rtf'; end;
5: begin ExpClass := TDBGridEhExportAsXLS; Ext := 'xls'; end;
else
ExpClass := nil; Ext := '';
end;
if ExpClass <> nil then
begin
if UpperCase(Copy(SaveDialog1.FileName,Length(SaveDialog1.FileName)-2,3)) <>
UpperCase(Ext) then
SaveDialog1.FileName := SaveDialog1.FileName + '.' + Ext;
SaveDBGridEhToExportFile(ExpClass,TDBGridEh(ActiveControl),
SaveDialog1.FileName,False);
end;
end;
end;