[-] 今天是: 设为首页 加入收藏
计算机 ASP ASP.NET VB JSP BS结构 管理系统 JAVA C/C++ Delphi Power Builder VFP PHP 网上书店 学生 图书 精品课程 论坛 考试 人事 基于web 企业 进销存 计算机应用 网站建设 编程 环境配置 外文翻译 电子 通信 PLC 单片机 电气 控制 智能 电源 CDMA GPRS 机械 数控车床 模具 钻床 土木工程 住宅楼 办公楼 教学楼 综合楼
您现在的位置: 爱毕业设计网 >> 计算机教程 >> 计算机编程 >> 正文
DELPHI基础开发技巧
编辑:未知 教程来源:网上收集 指数:           
先人的Delphi基础开发技巧



◇[Delphi]网络邻居复制文件

uses shellapi;

copyfile(pchar('newfile.txt'),pchar('//computername/direction/targer.txt'),false);



◇[Delphi]产生鼠标拖动效果

通过MouseMove事件、DragOver事件、EndDrag事件实现,例如在PANEL上的LABEL:

var xpanel,ypanel,xlabel,ylabel:integer;

PANEL的MouseMove事件:xpanel:=x;ypanel:=y;

PANEL的DragOver事件:xpanel:=x;ypanel:=y;

LABEL的MouseMove事件:xlabel:=x;ylabel:=y;

LABEL的EndDrag事件:label.left:=xpanel-xlabel;label.top:=ypanel-ylabel;



◇[Delphi]取得WINDOWS目录

uses shellapi;

var windir:array[0..255] of char;

getwindowsdirectory(windir,sizeof(windir));

或者从注册表中读取,位置:

HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion

SystemRoot键,取得如:C:\WINDOWS



◇[Delphi]在form或其他容器上画线

var x,y:array [0..50] of integer;

canvas.pen.color:=clred;

canvas.pen.style:=psDash;

form1.canvas.moveto(trunc(x[i]),trunc(y[i]));

form1.canvas.lineto(trunc(x[j]),trunc(y[j]));



◇[Delphi]字符串列表使用

var tips:tstringlist;

tips:=tstringlist.create;

tips.loadfromfile('filename.txt');

edit1.text:=tips[0];

tips.add('last line addition string');

tips.insert(1,'insert string at NO 2 line');

tips.savetofile('newfile.txt');

tips.free;



◇[Delphi]简单的剪贴板操作

richedit1.selectall;

richedit1.copytocliPBoard;

richedit1.cuttocliPBoard;

edit1.pastefromcliPBoard;



◇[Delphi]关于文件、目录操作

Chdir('c:\abcdir');转到目录

Mkdir('dirname');建立目录

Rmdir('dirname');删除目录

GetCurrentDir;//取当前目录名,无'\'

Getdir(0,s);//取工作目录名s:='c:\abcdir';

Deletfile('abc.txt');//删除文件

Renamefile('old.txt','new.txt');//文件更名

ExtractFilename(filelistbox1.filename);//取文件名

ExtractFileExt(filelistbox1.filename);//取文件后缀



◇[Delphi]处理文件属性

attr:=filegetattr(filelistbox1.filename);

if (attr and faReadonly)=faReadonly then ... //只读

if (attr and faSysfile)=faSysfile then ... //系统

if (attr and faArchive)=faArchive then ... //存档

if (attr and faHidden)=faHidden then ... //隐藏



◇[Delphi]执行程序外文件

WINEXEC//调用可执行文件

winexec('command.com /c copy *.* c:\',SW_Normal);

winexec('start abc.txt');

ShellExecute或ShellExecuteEx//启动文件关联程序

function executefile(const filename,params,defaultDir:string;showCmd:integer):THandle;

ExecuteFile('C:\abc\a.txt','x.abc','c:\abc\',0);

ExecuteFile('http://tingweb.yeah.net','','',0);

ExecuteFile('mailto:tingweb@wx88.net','','',0);



◇[Delphi]取得系统运行的进程名

var hCurrentWindow:HWnd;szText:array[0..254] of char;

begin

hCurrentWindow:=Getwindow(handle,GW_HWndFrist);

while hCurrentWindow <> 0 do

begin

if Getwindowtext(hcurrnetwindow,@sztext,255)>0 then listbox1.items.add(strpas(@sztext));

hCurrentWindow:=Getwindow(hCurrentwindow,GW_HWndNext);

end;

end;



◇[Delphi]关于汇编的嵌入

Asm End;

可以任意修改EAX、ECX、EDX;不能修改ESI、EDI、ESP、EBP、EBX。



◇[Delphi]关于类型转换函数

FloatToStr//浮点转字符串

FloatToStrF//带格式的浮点转字符串

IntToHex//整数转16进制

TimeToStr

DateToStr

DateTimeToStr

FmtStr//按指定格式输出字符串

formatDateTime('YYYY-MM-DD,hh-mm-ss',DATE);



◇[Delphi]字符串的过程和函数

Insert(obj,target,pos);//字符串target插入在pos的位置。如插入结果大于target最大长度,多出字符将被截掉。如Pos在255以外,会产生运行错。例如,st:='Brian',则Insert('OK',st,2)会使st变为'BrOKian'。

Delete(st,pos,Num);//从st串中的pos(整型)位置开始删去个数为Num(整型)个字符的子字串。例如,st:='Brian',则Delete(st,3,2)将变为Brn。

Str(value,st);//将数值value(整型或实型)转换成字符串放在st中。例如,a=2.5E4时,则str(a:10,st)将使st的值为' 25000'。

Val(st,var,code);//把字符串表达式st转换为对应整型或实型数值,存放在var中。St必须是一个表示数值的字符串,并符合数值常数的规则。在转换过程中,如果没有检测出错误,变量code置为0,否则置为第一个出错字符的位置。例如,st:=25.4E3,x是一个实型变量,则val(st,x,code)将使X值为25400,code值为0。

Copy(st.pos.num);//返回st串中一个位置pos(整型)处开始的,含有num(整型)个字符的子串。如果pos大于st字符串的长度,那就会返回一个空串,如果pos在255以外,会引起运行错误。例如,st:='Brian',则Copy(st,2,2)返回'ri'。

Concat(st1,st2,st3……,stn);//把所有自变量表示出的字符串按所给出的顺序连接起来,并返回连接后的值。如果结果的长度255,将产生运行错误。例如,st1:='Brian',st2:=' ',st3:='Wilfred',则Concat(st1,st2,st3)返回'Brian Wilfred'。

Length(st);//返回字符串表达式st的长度。例如,st:='Brian',则Length(st)返回值为5。

Pos(obj,target);//返回字符串obj在目标字符串target的第一次出现的位置,如果target没有匹配的串,Pos函数的返回值为0。例如,target:='Brian Wilfred',则Pos('Wil',target)的返回值是7,Pos('hurbet',target)的返回值是0。



◇[Delphi]关于处理注册表

uses Registry;

var reg:Tregistry;

reg:=Tregistry.create;

reg.rootkey:='HKey_Current_User';

reg.openkey('Control Panel\Desktop',false);

reg.WriteString('Title Wallpaper','0');

reg.writeString('Wallpaper',filelistbox1.filename);

reg.closereg;

reg.free;



◇[Delphi]关于键盘常量名

VK_BACK/VK_TAB/VK_RETURN/VK_SHIFT/VK_CONTROL/VK_MENU/VK_PAUSE/VK_ESCAPE

/VK_SPACE/VK_LEFT/VK_RIGHT/VK_UP/VK_DOWN

F1--F12:$70(112)--$7B(123)

A-Z:$41(65)--$5A(90)

0-9:$30(48)--$39(57)

◇[Delphi]初步判断程序母语

Delphi软件的DOS提示:This Program Must Be Run Under Win32.

VC++软件的DOS提示:This Program Cannot Be Run In DOS Mode.



◇[Delphi]操作Cookie

response.cookies("name").domain:='http://www.086net.com';

with response.cookies.add do

begin

name:='username';

value:='username';

end



◇[Delphi]增加到文档菜单连接

uses shellapi,shlOBJ;

shAddToRecentDocs(shArd_path,pchar(filepath));//增加连接

shAddToRecentDocs(shArd_path,nil);//清空



◇[杂类]备份智能ABC输入法词库

windows\system\user.rem

windows\system\tmmr.rem



◇[Delphi]判断鼠标按键

if GetAsyncKeyState(VK_LButton)<>0 then ... //左键

if GetAsyncKeyState(VK_MButton)<>0 then ... //中键

if GetAsyncKeyState(VK_RButton)<>0 then ... //右键



◇[Delphi]设置窗体的最大显示

onformCreate事件

self.width:=screen.width;

self.height:=screen.height;



◇[Delphi]按键接受消息

OnCreate事件中处理:Application.OnMessage:=MyOnMessage;

procedure Tform1.MyOnMessage(var MSG:TMSG;var Handle:Boolean);

begin

if msg.message=256 then ... //ANY键

if msg.message=112 then ... //F1

if msg.message=113 then ... //F2

end;



◇[杂类]隐藏共享文件夹

共享效果:可访问,但不可见(在资源管理、网络邻居中)

取共享名为:direction$

访问://computer/dirction/



◇[Java Script]JAVA Script网页常用效果

网页60秒定时关闭



关闭窗口

关闭

定时转URL



设为首页

设为首页

收藏本站

收藏本站

加入频道

加入频道





◇[Delphi]随机产生文本色

randomize;//随机种子

memo1.font.color:=rgb(random(255),random(255),random(255));



◇[DELPHI]Delphi5 UPDATE升级补丁序列号

1000003185

90X25fx0



◇[Delphi]文件名的非法字符过滤

for i:=1 to length(s) do

if s[i] in ['\','/',':','*','?','<','>','|'] then



◇[Delphi]转换函数的定义及说明

datetimetofiledate (datetime:Tdatetime):longint; 将Tdatetime格式的日期时间值转换成DOS格式的日期时间值

datetimetostr (datetime:Tdatetime):string; 将Tdatatime格式变量转换成字符串,如果datetime参数不包含日期值,返回字符串日期显示成为00/00/00,如果datetime参数中没有时间值,返回字符串中的时间部分显示成为00:00:00 AM

datetimetostring (var result string;

const format:string;

datetime:Tdatetime); 根据给定的格式字符串转换时间和日期值,result为结果字符串,format为转换格式字符串,datetime为日期时间值

datetostr (date:Tdatetime) 使用shortdateformat全局变量定义的格式字符串将date参数转换成对应的字符串

floattodecimal (var result:Tfloatrec;value:

extended;precision,decimals:

integer); 将浮点数转换成十进制表示

floattostr (value:extended):string 将浮点数value转换成字符串格式,该转换使用普通数字格式,转换的有效位数为15位。

floattotext (buffer:pchar;value:extended;

format:Tfloatformat;precision,

digits:integer):integer; 用给定的格式、精度和小数将浮点值value转换成十进制表示形式,转换结果存放于buffer参数中,函数返回值为存储到buffer中的字符位数,buffer是非0结果的字符串缓冲区。

floattotextfmt (buffer:pchar;value:extended;

format:pchar):integer 用给定的格式将浮点值value转换成十进制表示形式,转换结果存放于buffer参数中,函数返回值为存储到buffer中的字符位数。

inttohex (value:longint;digits:integer):

string; 将给定的数值value转换成十六进制的字符串。参数digits给出转换结果字符串包含的数字位数。

inttostr (value:longint):string 将整数转换成十进制形式字符串

strtodate (const S:string):Tdatetime 将字符串转换成日期值,S必须包含一个合法的格式日期的字符串。

strtodatetime (const S:string):Tdatetime 将字符串S转换成日期时间格式,S必须具有MM/DD/YY HH:MM:SS[AM|PM]格式,其中日期和时间分隔符与系统时期时间常量设置相关。如果没有指定AM或PM信息,表示使用24小时制。

strtofloat (const S:string):extended; 将给定的字符串转换成浮点数,字符串具有如下格式:

[+|-]nnn…[.]nnn…[<+|-><+|->nnnn]

strtoint (const S:string):longint 将数字字符串转换成整数,字符串可以是十进制或十六进制格式,如果字符串不是一个合法的数字字符串,系统发生ECONVERTERROR异常

strtointdef (const S:string;default:

longint):longint; 将字符串S转换成数字,如果不能将S转换成数字,strtointdef函数返回参数default的值。

strtotime (const S:string):Tdatetime 将字符串S转换成TDATETIME值,S具有HH:MM:SS[AM|PM]格式,实际的格式与系统的时间相关的全局变量有关。

timetostr (time:Tdatetime):string; 将参数TIME转换成字符串。转换结果字符串的格式与系统的时间相关常量的设置有关。



◇[Delphi]程序不出现在ALT+CTRL+DEL

在implementation后添加声明:

function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL';

RegisterServiceProcess(GetCurrentProcessID, 1);//隐藏

RegisterServiceProcess(GetCurrentProcessID, 0);//显示

用ALT+DEL+CTRL看不见



◇[Delphi]程序不出现在任务栏

uses windows

var

Extendedstyle : Integer;

begin

Application.Initialize;

//==============================================================

Extendedstyle := GetWindowLong (Application.Handle, GWL_EXstyle);

SetWindowLong(Application.Handle, GWL_EXstyle, Extendedstyle OR WS_EX_TOOLWINDOW

AND NOT WS_EX_APPWINDOW);

//===============================================================

Application.Createform(Tform1, form1);

Application.Run;

end.



◇[Delphi]如何判断拨号网络是开还是关

if GetSystemMetrics(SM_NETWORK) AND $01 = $01 then

showmessage('在线!')

else showmessage('不在线!');



◇[Delphi]实现IP到域名的转换

function GetDomainName(Ip:string):string;

var

pH:PHostent;

data:twsadata;

ii:dword;

begin

WSAStartup($101, Data);

ii:=inet_addr(pchar(ip));

pH:=gethostbyaddr(@ii,sizeof(ii),PF_INET);

if (ph<>nil) then

result:=pH.h_name

else

result:='';

WSACleanup;

end;



◇[Delphi]处理“右键菜单”方法

var

reg: TRegistry;

begin

reg := TRegistry.Create;

reg.RootKey:=HKEY_CLASSES_ROOT;

reg.OpenKey('*\shell\check\command', true);

reg.WriteString('', '"' + application.ExeName + '" "%1"');

reg.CloseKey;

reg.OpenKey('*\shell\diary', false);

reg.WriteString('', '操作(&C)');

reg.CloseKey;

reg.Free;

showmessage('DONE!');

end;



◇[Delphi]发送虚拟键值ctrl V

procedure sendpaste;

begin

keybd_event(VK_Control, MapVirtualKey(VK_Control, 0), 0, 0);

keybd_event(ord('V'), MapVirtualKey(ord('V'), 0), 0, 0);

keybd_event(ord('V'), MapVirtualKey(ord('V'), 0), KEYEVENTF_KEYUP, 0);

keybd_event(VK_Control, MapVirtualKey(VK_Control, 0), KEYEVENTF_KEYUP, 0);

end;



◇[Delphi]当前的光驱的盘符

procedure getcdrom(var cd:char);

var

str:string;

drivers:integer;

driver:char;

i,temp:integer;

begin

drivers:=getlogicaldrives;

temp:=(1 and drivers);

for i:=0 to 26 do

begin

if temp=1 then

begin

driver:=char(i+integer('a'));

str:=driver+':';

if getdrivetype(pchar(str))=drive_cdrom then

begin

cd:=driver;

exit;

end;

end;

drivers:=(drivers shr 1);

temp:=(1 and drivers);

end;

end;



◇[Delphi]字符的加密与解密

function cryptstr(const s:string; stype: dword):string;

var

i: integer;

fkey: integer;

begin

result:='';

case stype of

0: setpass;

begin

randomize;

fkey := random($ff);

for i:=1 to length(s) do

result := result+chr( ord(s[i]) xor i xor fkey);

result := result + char(fkey);

end;

1: getpass

begin

fkey := ord(s[length(s)]);

for i:=1 to length(s) - 1 do

result := result+chr( ord(s[i]) xor i xor fkey);

end;

end;



□◇[Delphi]向其他应用程序发送模拟键

var

h: THandle;

begin

h := FindWindow(nil, '应用程序标题');

PostMessage(h, WM_KEYDOWN, VK_F9, 0);//发送F9键

end;



□◇[DELPHI]Delphi 支持的DAO数据格式

td.Fields.Append(td.CreateField ('dbBoolean',dbBoolean,0));

td.Fields.Append(td.CreateField ('dbByte',dbByte,0));

td.Fields.Append(td.CreateField ('dbInteger',dbInteger,0));

td.Fields.Append(td.CreateField ('dbLong',dbLong,0));

td.Fields.Append(td.CreateField ('dbCurrency',dbCurrency,0));

td.Fields.Append(td.CreateField ('dbSingle',dbSingle,0));

td.Fields.Append(td.CreateField ('dbDouble',dbDouble,0));

td.Fields.Append(td.CreateField ('dbDate',dbDate,0));

td.Fields.Append(td.CreateField ('dbBinary',dbBinary,0));

td.Fields.Append(td.CreateField ('dbText',dbText,0));

td.Fields.Append(td.CreateField ('dbLongBinary',dbLongBinary,0));

td.Fields.Append(td.CreateField ('dbMemo',dbMemo,0));

td.Fields['ID'].Set_Attributes(dbAutoIncrField);//自增字段



□◇[DELPHI]Delphi配置MS SQL 7和BDE步骤

第一步,配置ODBC:

先在ODBC 中设数据源,安装过SQL Server7.0 后,ODBC中有一项"系统DSN"应该有两项

数据源,一个是MQIS,一个是LocalSever,任选一个选后点击配置按钮,不知你的SQL7.0

是不是安装在本地机器上,如果是的话直接进行下一步,如果不是,在服务器一栏中填上

Server,然后进行下一步,填写登录ID 和密码(登录ID,和密码是在SQL7.0中的用户选项

中设的)。

第二步,配置BDE:

打开Delphi的BDE,然后点击MQIS 或 LocalServer,就会提示用户名和密码,这和

ODBC的用户名和密码是一样的,填上就行了。

第三步,配置程序:

如果用的是TTable,就在TTable的DatabaseName中选择MQIS 或LocalServer,然后在

TableName中选择Sale就行了,然后将Active改为True,Delphi弹出提示对话,填入用户

名和密码。

如果用的是TQuery,在TQuery上点击右键,再击"SQL Builder",这是以界面方式配置

SQL语句,或者在TQuery的SQL中填入SQL语句。最后,别忘了将Active改为True。

在运行也可能配置TQuery,具体见Delphi帮助。



□◇[Delphi]得到图像上某一点的RGB值

procedure Tform1.Image1MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

var

red,green,blue:byte ;

i:integer;

begin

i:= image1.Canvas.Pixels[x,y];

Blue:= GetBvalue(i);

Green:= GetGvalue(i):

Red:= GetRvalue(i);

Label1.Caption:=inttostr(Red);

Label2.Caption:=inttostr(Green);

Label3.Caption:=inttostr(Blue);

end;



□◇[Delphi]关于日期格式分解转换

var year,month,day:word;now2:Tdatatime;

now2:=date();

decodedate(now2,year,month,day);

lable1.Text :=inttostr(year)+'年'+inttostr(month)+'月'+inttostr(day)+'日';



◇[Delphi]如何判断当前网络连接方式

判断结果是MODEM、局域网或是代理服务器方式。

uses wininet;

Function ConnectionKind :boolean;

var flags: dword;

begin

Result := InternetGetConnectedState(@flags, 0);

if Result then

begin

if (flags and INTERNET_CONNECTION_MODEM) = INTERNET_CONNECTION_MODEM then

begin

showmessage('Modem');

end;

if (flags and INTERNET_CONNECTION_LAN) = INTERNET_CONNECTION_LAN then

begin

showmessage('LAN');

end;

if (flags and INTERNET_CONNECTION_PROXY) = INTERNET_CONNECTION_PROXY then

begin

showmessage('Proxy');

end;

if (flags and INTERNET_CONNECTION_MODEM_BUSY)=INTERNET_CONNECTION_MODEM_BUSY then

begin

showmessage('Modem Busy');

end;

end;

end;



◇[Delphi]如何判断字符串是否是有效EMAIL地址

function IsEMail(EMail: String): Boolean;

var s: String;ETpos: Integer;

begin

ETpos:= pos('@', EMail);

if ETpos > 1 then

begin

s:= copy(EMail,ETpos+1,Length(EMail));

if (pos('.', s) > 1) and (pos('.', s) < length(s)) then

Result:= true else Result:= false;

end

else

Result:= false;

end;



◇[Delphi]判断系统是否连接INTERNET

需要引入URL.DLL中的InetIsOffline函数。

函数申明为:

function InetIsOffline(Flag: Integer): Boolean; stdcall; external 'URL.DLL';

然后就可以调用函数判断系统是否连接到INTERNET

if InetIsOffline(0) then ShowMessage('not connected!')

else ShowMessage('connected!');

该函数返回TRUE如果本地系统没有连接到INTERNET。

附:

大多数装有IE或OFFICE97的系统都有此DLL可供调用。

InetIsOffline

BOOL InetIsOffline(

DWORD dwFlags,

);



◇[Delphi]简单地播放和暂停WAV文件

uses mmsystem;



function PlayWav(const FileName: string): Boolean;

begin

Result := PlaySound(PChar(FileName), 0, SND_ASYNC);

end;



procedure StopWav;

var

buffer: array[0..2] of char;

begin

buffer[0] := #0;

PlaySound(Buffer, 0, SND_PURGE);

end;



◇[Delphi]取机器BIOS信息

with Memo1.Lines do

begin

Add('MainBoardBiosName:'+^I+string(Pchar(Ptr($FE061))));

Add('MainBoardBiosCopyRight:'+^I+string(Pchar(Ptr($FE091))));

Add('MainBoardBiosDate:'+^I+string(Pchar(Ptr($FFFF5))));

Add('MainBoardBiosSerialNo:'+^I+string(Pchar(Ptr($FEC71))));

end;



◇[Delphi]网络下载文件

uses UrlMon;



function DownloadFile(Source, Dest: string): Boolean;

begin

try

Result := UrlDownloadToFile(nil, PChar(source), PChar(Dest), 0, nil) = 0;

except

Result := False;

end;

end;



if DownloadFile('http://www.borland.com/Delphi6.zip, 'c:\kylix.zip') then

ShowMessage('Download succesful')

else ShowMessage('Download unsuccesful')



◇[Delphi]解析服务器IP地址

uses winsock



function IPAddrToName(IPAddr : String): String;

var

SockAddrIn: TSockAddrIn;

HostEnt: PHostEnt;

WSAData: TWSAData;

begin

WSAStartup($101, WSAData);

SockAddrIn.sin_addr.s_addr:= inet_addr(PChar(IPAddr));

HostEnt:= gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET);

if HostEnt<>nil then result:=StrPas(Hostent^.h_name) else result:='';

end;



◇[Delphi]取得快捷方式中的连接

function ExeFromLink(const linkname: string): string;

var

FDir,

FName,

ExeName: PChar;

z: integer;

begin

ExeName:= StrAlloc(MAX_PATH);

FName:= StrAlloc(MAX_PATH);

FDir:= StrAlloc(MAX_PATH);

StrPCopy(FName, ExtractFileName(linkname));

StrPCopy(FDir, ExtractFilePath(linkname));

z:= FindExecutable(FName, FDir, ExeName);

if z > 32 then

Result:= StrPas(ExeName)

else

Result:= '';

StrDispose(FDir);

StrDispose(FName);

StrDispose(ExeName);

end;



◇[Delphi]控制TCombobox的自动完成

{'Sorted' property of the TCombobox to true }

var lastKey: Word; //全局变量

//TCombobox的OnChange事件

procedure Tform1.AutoCompleteChange(Sender: TObject);

var

SearchStr: string;

retVal: integer;

begin

SearchStr := (Sender as TCombobox).Text;

if lastKey <> VK_BACK then // backspace: VK_BACK or $08

begin

retVal := (Sender as TCombobox).Perform(CB_FINDSTRING, -1, LongInt(PChar(SearchStr)));

if retVal > CB_Err then

begin

(Sender as TCombobox).ItemIndex := retVal;

(Sender as TCombobox).SelStart := Length(SearchStr);

(Sender as TCombobox).SelLength :=

(Length((Sender as TCombobox).Text) - Length(SearchStr));

end; // retVal > CB_Err

end; // lastKey <> VK_BACK

lastKey := 0; // reset lastKey

end;

//TCombobox的onKeyDown事件

procedure Tform1.AutoCompleteKeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

lastKey := Key;

end;



◇[Delphi]如何清空一个目录

function EmptyDirectory(TheDirectory :String ; Recursive : Boolean) :

Boolean;

var

SearchRec : TSearchRec;

Res : Integer;

begin

Result := False;

TheDirectory := NormalDir(TheDirectory);

Res := FindFirst(TheDirectory + '*.*', faAnyFile, SearchRec);

try

while Res = 0 do

begin

if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then

begin

if ((SearchRec.Attr and faDirectory) > 0) and Recursive

then begin

EmptyDirectory(TheDirectory + SearchRec.Name, True);

RemoveDirectory(PChar(TheDirectory + SearchRec.Name));

end

else begin

DeleteFile(PChar(TheDirectory + SearchRec.Name))

end;

end;

Res := FindNext(SearchRec);

end;

Result := True;

finally

FindClose(SearchRec.FindHandle);

end;

end;



◇[Delphi]安装程序如何添加到Uninstall列表

操作注册表,如下:

1.在HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall键下建立一个主键,名称任意。

例HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\MyUninstall

2.在HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\MyUnistall下键两个串值,

这两个串值的名称是特定的:DisplayName和UninstallString。

3.给串DisplayName赋值为显示在“删除应用程序列表”中的名称,如'Aiming Uninstall one';

给串UninstallString赋值为执行的删除命令,如 C:\WIN97\uninst.exe -f"C:\TestPro\aimTest.isu"



◇[Delphi]截获WM_QUERYENDSESSION关机消息

type

Tform1 = class(Tform)

procedure WMQueryEndSession(var Message: TWMQueryEndSession); message WM_QUERYENDSESSION;

procedure CMEraseBkgnd(var Message:TWMEraseBkgnd);Message WM_ERASEBKGND;

private

{ Private declarations }

public

{ Public declarations }

end;



procedure Tform1.WMQueryEndSession(var Message: TWMQueryEndSession);

begin

Showmessage('computer is about to shut down');

end;



◇[Delphi]获取网上邻居

procedure getnethood();//NT做服务器,WIN98上调试通过。

var

a,i:integer;

errcode:integer;

netres:array[0..1023] of netresource;

enumhandle:thandle;

enumentries:dword;

buffersize:dword;

s:string;

mylistitems:tlistitems;

mylistitem:tlistitem;

alldomain:tstrings;

begin //listcomputer is a listview to list all computers;controlcenter is a form.

alldomain:=tstringlist.Create ;

with netres[0] do begin

dwscope :=RESOURCE_GLOBALNET;

dwtype :=RESOURCETYPE_ANY;

dwdisplaytype :=RESOURCEDISPLAYTYPE_DOMAIN;

dwusage :=RESOURCEUSAGE_CONTAINER;

lplocalname :=nil;

lpremotename :=nil;

lpcomment :=nil;

lpprovider :=nil;

end; // 获取所有的域

errcode:=wnetopenenum(RESOURCE_GLOBALNET,RESOURCETYPE_ANY,RESOURCEUSAGE_CONTAINER,@netres[0],enumhandle);

if errcode=NO_ERROR then begin

enumentries:=1024;

buffersize:=sizeof(netres);

errcode:=wnetenumresource(enumhandle,enumentries,@netres[0],buffersize);

end;

a:=0;

mylistitems :=controlcenter.lstcomputer.Items ;

mylistitems.Clear ;

while (string(netres[a].lpprovider)<>'') and (errcode=NO_ERROR) do

begin

alldomain.Add (netres[a].lpremotename);

a:=a+1;

end;

wnetcloseenum(enumhandle);

// 获取所有的计算机

mylistitems :=controlcenter.lstcomputer.Items ;

mylistitems.Clear ;

for i:=0 to alldomain.Count-1 do

begin

with netres[0] do begin

dwscope :=RESOURCE_GLOBALNET;

dwtype :=RESOURCETYPE_ANY;

dwdisplaytype :=RESOURCEDISPLAYTYPE_SERVER;

dwusage :=RESOURCEUSAGE_CONTAINER;

lplocalname :=nil;

lpremotename :=pchar(alldomain[i]);

lpcomment :=nil;

lpprovider :=nil;

end;

ErrCode:=WNetOpenEnum(RESOURCE_GLOBALNET,RESOURCETYPE_ANY,RESOURCEUSAGE_CONTAINER,@netres[0],EnumHandle);

if errcode=NO_ERROR then

begin

EnumEntries:=1024;

BufferSize:=SizeOf(NetRes);

ErrCode:=WNetEnumResource(EnumHandle,EnumEntries,@NetRes[0],BufferSize);

end;

a:=0;

while (string(netres[a].lpprovider)<>'') and (errcode=NO_ERROR) do

begin

mylistitem :=mylistitems.Add ;

mylistitem.ImageIndex :=0;

mylistitem.Caption :=uppercase(stringreplace(string(NetRes[a].lpremotename),'\\','',[rfReplaceAll]));

a:=a+1;

end;

wnetcloseenum(enumhandle);

end;

end;



◇[Delphi]获取某一计算机上的共享目录

procedure getsharefolder(const computername:string);

var

errcode,a:integer;

netres:array[0..1023] of netresource;

enumhandle:thandle;

enumentries,buffersize:dword;

s:string;

mylistitems:tlistitems;

mylistitem:tlistitem;

mystrings:tstringlist;

begin

with netres[0] do begin

dwscope :=RESOURCE_GLOBALNET;

dwtype :=RESOURCETYPE_DISK;

dwdisplaytype :=RESOURCEDISPLAYTYPE_SHARE;

dwusage :=RESOURCEUSAGE_CONTAINER;

lplocalname :=nil;

lpremotename :=pchar(computername);

lpcomment :=nil;

lpprovider :=nil;

end; // 获取根结点

errcode:=wnetopenenum(RESOURCE_GLOBALNET,RESOURCETYPE_DISK,RESOURCEUSAGE_CONTAINER,@netres[0],enumhandle);

if errcode=NO_ERROR then

begin

EnumEntries:=1024;

BufferSize:=SizeOf(NetRes);

ErrCode:=WNetEnumResource(EnumHandle,EnumEntries,@NetRes[0],BufferSize);

end;

wnetcloseenum(enumhandle);

a:=0;

mylistitems:=controlcenter.lstfile.Items ;

mylistitems.Clear ;

while (string(netres[a].lpprovider)<>'') and (errcode=NO_ERROR) do

begin

with mylistitems do

begin

mylistitem:=add;

mylistitem.ImageIndex :=4;

mylistitem.Caption :=extractfilename(netres[a].lpremotename);

end;

a:=a+1;

end;

end;



◇[Delphi]得到硬盘序列号

var SerialNum : pdword; a, b : dword; Buffer : array [0..255] of char;

begin

if GetVolumeInformation('c:\', Buffer, SizeOf(Buffer), SerialNum, a, b, nil, 0) then Label1.Caption := IntToStr(SerialNum^);

end;





1.关于MDI主窗体背景新解

在Form中添加Image控件

设BMP图象

name为 IMG_BK

在Foem的Create事件中写入

Self.brush.bitmap:=img_bk.picture.bitmap;



2.在标题栏处画VCL控件(一行解决问题!!!)

在 form 的onpaint 事件中

控件.pointto(getdc(0),left,top);



3 Edit 中只输入数字

SetWindowLong(Edit1.Handle, GWL_STYLE,

GetWindowLong(Edit1.Handle, GWL_STYLE) or

ES_NUMBER);

4.类似MDI方式新解

在要设置child的oncreate方式下写入:

self.parent:='要设置为mainform的Form';



5. 屏幕的Refresh(只需一行!)

RedrawWindow(0,nil,0,RDW_ERASE or RDW_INVALIDATE or RDW_ALLCHILDREN);

| |

--- ----

handle RGN(可刷新局部屏幕)

6.类似DOS下的CLS指令的WINDOWS指令!

paintdesktop(getdc(0));



7.扩展控件新功能

在编程中 ,我们经常要控制控件的动作,但该控件又没有提供该方法



这时 ,可通过发消息给该控件 ,以达到我们的目的!



如:

button1.perform(wm_keydown,13,0);



listbox1.perform(wm_vscroll,sb_linedown,0);



8.闪烁标题如打印机超时(一行)

form 放一timer 控件



time 事件 中 写入 ;



flashwindow(application.handle,true);





9.在桌面上加个VCL控件!(不是画的,不可refresh)

windows.setparent(控件.handle,0);



注: 想放哪都行 (如'开始处状态栏')





10.关于 '类似MDI方式新解(一行就行!!!!)'的修正

windows.setparent(self.handle,'要设置为mainform的Form');



11 普通Form象MDI中mainform始终在最底层

SetActiveWindow(0);

或 SetwindowPos(...);

12 执行下列语句开始Windows屏幕保护程序

SendMessage(HWND_BROADCAST,WM_SYSCOMMAND,SC_SCREENSAVE,0);

13 button 的 caption 多行显示:

SetWindowLong(Button1.handle, GWL_STYLE,

GetWindowlong(Button1.Handle, GWL_STYLE) or

BS_MULTILINE);

必要时加上 Button1.Invalidate;



14.整死windows98 :)

asm int $19 end



Q: 怎么来改变ListBox的字体呢?就修改其中的一行。



A: 先把ListBox1.Style 设成lbOwnerDrawFixed

然后在 OnDrawItem 事件下写下如下代码



procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;

Rect: TRect; State: TOwnerDrawState);

var

Offset: Integer;

begin

Offset := 2;

with (Control as TListBox).Canvas do begin

FillRect(Rect);

if Index = 2 then begin

Font.Name := 'Fixedsys';

Font.Color := clRed;

Font.Size := 12;

end else begin

Font.Name := 'Arial';

Font.Color := clBlack;

Font.Size := 8;

end;

if odSelected in State then begin

Font.Color := clWhite;

end;

TextOut(Rect.Left + Offset, Rect.Top, (Control as TListBox).Items[Index]);

end;

end;





Q:怎么在RichEdit里面插入图片?



A: 请到这里来看看会找到答案



http://www.undu.com/Articles/991107c.html





Q:怎么才能目录呢?



A:我来。



uses ShellAPI;



procedure DeleteFiles(Source: string);

var

FO: TShFileOpStruct;

begin

FillChar(FO,SizeOf(FO),#0);

FO.Wnd := Form1.Handle;

FO.wFunc := FO_DELETE;

FO.pFrom := PChar(Source);

ShFileOperation(FO);

end;



procedure EmptyDirectory(Path: String);

begin

if DirectoryExists(Path) then

begin

DeleteFiles(Path+'\*');

end

else

ForceDirectories(Path);

end;



Q:如何映射网络驱动器?



比如我要把file://Server/sys映射为F盘。我需要一个函数比如



给出输入参数为file://server/sys/home/bruno给我的返回值是F:\home\bruno



A:



Function UNCToDrive(UNCPath: STring): STring;

var

DriveNum: Integer;

DriveChar: Char;

DriveBits: set of 0..25;

StartSTr,TestStr: STring;

begin

result := UNCPath;

StartSTr := UNCPath;

Integer(DriveBits) := GetLogicalDrives;

for DriveNum := 0 to 25 do

begin

if (DriveNum in DriveBits) then begin

DriveChar := Char(DriveNum + Ord('A'));

TestSTr := ExpandUNCFileName(DriveChar+':\');

If TEstStr <> '' then

If Pos(Uppercase(TestSTr),Uppercase(STartSTr)) > 0 then

begin

Delete(StartSTr,1,Length(TestSTr));

result := DriveChar+':\'+StartSTr;

break;

end;

end;

end;

end;





Q:我有一些特殊语言的字体来用,它们存储在我的EXE文件里,但是两点。



* 我不想放到font文件夹里

* 我不想从EXE文件里面提取出来



如果可能,请告诉我。



因为,我的字体是自己做的不是windows自带的,我想保护自己的东西。



A:不太可能,必须提取出来。你可以使用这个保护过程来保护你的文件不被修改和删除。



在EXE执行的时候把字体放到临时文件夹里,结束的时候删除它。



function ProtectFile(sFilename : string) : hFile;

var

hf: hFile;

lwHFileSize, lwFilesize: longword;

ofs : TOFStruct;

begin

if FileExists(sFilename) then

begin

hf := OpenFile(pchar(sFilename), ofs, OF_READ or OF_WRITE or OF_SHARE_EXCLUSIVE);

if hf <> 0 then

begin

lwFilesize := GetFileSize(hf, @lwHFileSize);

if LockFile(hf, 0, 0, lwFilesize, lwHFilesize) then

Result := hf else Result := 0;

end

else Result := 0;

end

else Result := 0;

end;



//..

var

ResS: TResourceStream;

TempPath: array [0..MAX_PATH] of Char;

TempDir: string;

begin

GetTempPath(Sizeof(TempPath), TempPath);

TempDir := StrPas(Path);

ResS := TResourceStream.Create(hInstance, 'SOME_FONT', 'RT_FONT');

ResS.SavetoFile(TempDir+'some_font.ttf');

ResS.Free;

AddFontResource(TempDir+'some_font.ttf');

SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);

ProtectFile(TempDir+'some_font.ttf');

end;





Q:如何得到当前的ProgramFiles得路径?



A:用读写注册表的方法就可以做到。



代码如下:



uses registry;



procedure TForm1.Button1Click(Sender: TObject);

var

reg:TRegistry;

begin

reg:=TRegistry.Create;

reg.RootKey:=HKEY_LOCAL_MACHINE;

if reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion',false) then

begin

edit1.Text:=reg.ReadString('ProgramFilesDir');

reg.CloseKey;

reg.Free;

end;

end;





Q:如何在Jpg图像上写上字?



A:这里有个代码。



hmm, here's a sample with help of Bitmap, you can chance the brush style of canvas to bsClear to make the text transparent



uses

Jpeg;



procedure TForm1.Button1Click(Sender: TObject);

var

Bmp : TBitmap;

Jpg : TJpegImage;

begin

try

Bmp := TBitmap.Create;

Jpg := TjpegImage.Create;

Jpg.LoadFromFile('c:\img.jpg');

Bmp.Assign(Jpg);

Bmp.Canvas.Brush.Style := bsClear;

Bmp.Canvas.Font.Color := clYellow;

Bmp.Canvas.TextOut(10,10,'Hello World');

Jpg.Assign(Bmp);

Jpg.SaveToFile('c:\img2.jpg');

finally

bmp.Free;

jpg.Free;

end;

end;



Q:怎么用Delphi修改文件的时间呢?



在windows下,属性里面有三个日起,创建,修改,存储。我怎么来修改啊?



A:Here is the excerpt from the Jedi Code Library. If it is not complete then get the JCL.



type

// indicates the file time to set, used by SetFileTimesHelper and SetDirTimesHelper

TFileTimes = (ftLastAccess, ftLastWrite, ftCreation);



function SetFileTimesHelper(const FileName: string; const DateTime: TDateTime; Times: TFileTimes): Boolean;

var

Handle: THandle;

FileTime: TFileTime;

SystemTime: TSystemTime;

begin

Result := False;

Handle := CreateFile(PChar(FileName), GENERIC_WRITE, FILE_SHARE_READ, nil,

OPEN_EXISTING, 0, 0);

if Handle <> INVALID_HANDLE_VALUE then

try

//SysUtils.DateTimeToSystemTime(DateTimeToLocalDateTime(DateTime), SystemTime);

SysUtils.DateTimeToSystemTime(DateTime, SystemTime);

if Windows.SystemTimeToFileTime(SystemTime, FileTime) then

begin

case Times of

ftLastAccess:

Result := SetFileTime(Handle, nil, @FileTime, nil);

ftLastWrite:

Result := SetFileTime(Handle, nil, nil, @FileTime);

ftCreation:

Result := SetFileTime(Handle, @FileTime, nil, nil);

end;

end;

finally

CloseHandle(Handle);

end;

end;



//--------------------------------------------------------------------------------------------------



function SetFileLastAccess(const FileName: string; const DateTime: TDateTime): Boolean;

begin

Result := SetFileTimesHelper(FileName, DateTime, ftLastAccess);

end;



//--------------------------------------------------------------------------------------------------



function SetFileLastWrite(const FileName: string; const DateTime: TDateTime): Boolean;

begin

Result := SetFileTimesHelper(FileName, DateTime, ftLastWrite);

end;



//--------------------------------------------------------------------------------------------------



function SetFileCreation(const FileName: string; const DateTime: TDateTime): Boolean;

begin

Result := SetFileTimesHelper(FileName, DateTime, ftCreation);

end;



google上的有关Delphi得网址:



http://directory.google.com/Top/Computers/Programming/Languages/Delphi/?tc=1



yahoo上有关Delphi得网址



http://dir.yahoo.com/Computers_and_Internet/Programming_and_Development/Languages/Delphi/



删掉程序自己的exe文件

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

var

F:TextFile;

begin

AssignFile(F,'delself.bat');

Rewrite(F);{F为TextFile类型}

WriteLn(F,'del '+ExtractFileName(Application.ExeName));

WriteLn(F,'del %0'); //删除自己delself.bat

CloseFile(F);

WinExec('delself.bat',SW_HIDE);

end;





if ord(s[9])>128 then

ShowMessage('该位置字符是汉字');

汉字是双字节的

更改系统时间格式:



var

str: string;

begin

str := 'yyyy-mm-dd';

if SetLocaleInfoa(LOCALE_SYSTEM_DEFAULT, LOCALE_SLONGDATE, PChar(str)) then

begin

showmessage('更改日期格式成功');

end;

end;



休息一分钟:

var

I:integer;

begin

i:=gettickcount;

while (Gettickcount-i)<=10000 do

application.ProcessMessages;//保证消息循环

end;

取主文件名:

function retuFileName(const FileName: string): string;

var

I: Integer;

begin

I := LastDelimiter('.', FileName);

Result := Copy(FileName, 1, i-1);



end;



(1).按下ctrl和其它键之后发生一事件。

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

if (ssCtrl in Shift) and (key =67) then

showmessage('keydown Ctrl+C');

end;

(2).Dbgrid中用Enter键代替Tab键.

procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char);

begin

if Key = #13 then

if ActiveControl = DBGrid1 then

begin

TDBGrid(ActiveControl).SelectedIndex := TDBGrid(ActiveControl).SelectedIndex + 1;

Key := #0;

end;

end;

(3).Dbgrid中选择多行发生一事件。

procedure TForm1.Button1Click(Sender: TObject);

var

i:integer;

bookmarklist:Tbookmarklist;

bookmark:tbookmarkstr;

begin

bookmark:=adoquery1.Bookmark;

bookmarklist:=dbgrid1.SelectedRows;

try

begin

for i:=0 to bookmarklist.Count-1 do

begin

adoquery1.Bookmark:=bookmarklist[i];

with adoquery1 do

begin

edit;

fieldbyname('mdg').AsString:=edit2.Text;

post;

end;

end;

end;

finally

adoquery1.Bookmark:=bookmark;

end;

end;

(4).Form的一个出现效果。

procedure TForm1.Button1Click(Sender: TObject);

var

r:thandle;

i:integer;

begin

for i:=1 to trunc(width/1.414) do

begin

r:=CreateEllipticRgn(trunc(width/2)-i,trunc(height/2)-i,trunc(width/2)+i,trunc(height/2)+i);

SetWindowRgn(handle,r,true);

Application.ProcessMessages;

sleep(1);

end;

end;

(5).用Enter代替Tab在编辑框中移动隹点。

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);

begin

if key=#13 then

begin

if not (Activecontrol is Tmemo) then

begin

key:=#0;

keybd_event(vk_tab,mapvirtualkey(vk_tab,0),0,0);

end;

end;

end;

(6).Progressbar加上色彩。

const

{$EXTERNALSYM PBS_MARQUEE}

PBS_MARQUEE = 08;

var

Form1: TForm1;

implementation

{$R *.dfm}

uses

CommCtrl;

procedure TForm1.Button1Click(Sender: TObject);

begin

// Set the Background color to teal

Progressbar1.Brush.Color := clTeal;

// Set bar color to yellow

SendMessage(ProgressBar1.Handle, PBM_SETBARCOLOR, 0, clYellow);

end;

(7).住点移动时编辑框色彩不同。

procedure TForm1.Edit1Enter(Sender: TObject);

begin

(sender as tedit).Color:=clred;

end;

procedure TForm1.Edit1Exit(Sender: TObject);

begin

(sender as tedit).Color:=clwhite;

end;

(8).备份和恢复

procedure TForm1.Button1Click(Sender: TObject);

begin

if OpenDialog1.Execute then

begin

try

adoconnection1.Connected:=False;

adoconnection1.ConnectionString:='Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=master;Data Source=FRIEND-YOFZKSCO;'+

'Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;Workstation ID=FRIEND-YOFZKSCO;Use Encryption for Data=False;Tag with column collation when possible=False';

adoconnection1.Connected:=True;

with adoQuery1 do

begin

Close;

SQL.Clear;

SQL.Add('Backup DataBase sfa to disk ='''+opendialog1.FileName+'''');

ExecSQL;

end;

except

ShowMessage('±?·Y꧰ü');

Exit;

end;

end;

Application.MessageBox('1§?2?ú£?êy?Y±?·Y3é1|','ìáê?',MB_OK + MB_ICONINFORMATION);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

if OpenDialog1.Execute then

begin

try

adoconnection1.Connected:=false;

adoconnection1.ConnectionString:='Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=master;Data Source=FRIEND-YOFZKSCO;'+

'Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;Workstation ID=FRIEND-YOFZKSCO;Use Encryption for Data=False;Tag with column collation when possible=False';

adoconnection1.Connected:=true;

with adoQuery1 do

begin

Close;

SQL.Clear;

SQL.Add('Restore DataBase sfa from disk ='''+opendialog1.FileName+'''');

ExecSQL;

end;

except

ShowMessage('???′꧰ü');

Exit;

end;

end;

Application.MessageBox('1§?2?ú£?êy?Y???′3é1|','ìáê?',MB_OK + MB_ICONINFORMATION);

end;





(9).查找局域网上的sqlserver报务器。

uses Comobj;

procedure TForm1.Button1Click(Sender: TObject);

var

SQLServer:Variant;

ServerList:Variant;

i,nServers:integer;

sRetValue:String;

begin

SQLServer := CreateOleObject('SQLDMO.Application');

ServerList:= SQLServer.ListAvailableSQLServers;

nServers:=ServerList.Count;

for i := 1 to nservers do

ListBox1.Items.Add(ServerList.Item(i));

SQLServer:=NULL;

serverList:=NULL;

end;

(10).窗体打开时的淡入效果。

procedure TForm1.FormCreate(Sender: TObject);

begin

AnimateWindow (Handle, 400, AW_CENTER);

end;

(11).动态创建窗体。

procedure TForm1.Button1Click(Sender: TObject);

begin

try

form2:=Tform2.Create(self);

form2.ShowModal;

finally

form2.Free;

end;

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

action:=cafree;

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

form1:=nil;

end;

(12).复制文件。

procedure TForm1.Button1Click(Sender: TObject);

begin

try

copyfileA(pchar('C:\AAA.txt'),pchar('D:\AAA.txt'),false);

except

showmessage('sfdsdf');

end;

end;

(13).复制文件夹。

uses shellAPI;

procedure TForm1.Button1Click(Sender: TObject);

var

lpFileOp: TSHFileOpStruct;

begin

with lpFileOp do

begin

Wnd:=Self.Handle;

wfunc:=FO_COPY;

pFrom:=pchar('C:\AAA');

pTo:=pchar('D:\AAA');

fFlags:=FOF_ALLOWUNDO;

hNameMappings:=nil;

lpszProgressTitle:=nil;

fAnyOperationsAborted:=True;

end;

if SHFileOperation(lpFileOp)<>0 then

ShowMessage('删除失败');

end;

(14).改变Dbgrid的选定色。

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;

Field: TField; State: TGridDrawState);

begin

if gdSelected in state then

SetBkColor(dbgrid1.canvas.handle,clgreen)

else

setbkcolor(dbgrid1.canvas.handle,clwhite);

dbgrid1.Canvas.TextRect(rect,0,0,field.AsString);

dbgrid1.Canvas.Textout(rect.Left,rect.Top,field.AsString);

end;

(15).检测系统是否已安装了ADO。

uses registry;

function Tform1.ADOInstalled:Boolean;

var

r:TRegistry;

s:string;

begin

r := TRegistry.create;

try

with r do

begin

RootKey := HKEY_CLASSES_ROOT;

OpenKey( '\ADODB.Connection\CurVer', false );

s := ReadString('');

if s <> '' then Result := True

else Result := False;

CloseKey;

end;

finally

r.free;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if ADOInstalled then showmessage('this computer has installed ADO');

end;

(16).取利主机的ip地址。

uses winsock;

procedure TForm1.Button1Click(Sender: TObject);

var

IP:string;

IPstr:String;

buffer:array[1..32] of char;

i:integer;

WSData:TWSAdata;

Host:PHostEnt;

begin

if WSAstartup(2,WSData)<>0 then

begin

showmessage('WS2_32.DLL3?ê??ˉ꧰ü.');

exit;

end;

try

if GetHostname(@buffer[1],32)<>0 then

begin

showmessage('??óDμ?μ??÷?ú??.');

exit;

end;

except

showmessage('??óD3é1|·μ???÷?ú??');

exit;

end;

Host:=GetHostbyname(@buffer[1]);

if Host=nil then

begin

showmessage('IPμ??·?a??.');

exit;

end

else

begin

edit2.Text:=Host.h_name;

edit3.Text:=chr(host.h_addrtype+64);

for i:=1 to 4 do

begin

IP:=inttostr(ord(host.h_addr^[i-1]));

if i<4 then

ipstr:=ipstr+IP+'.'

else

edit1.Text:=ipstr+ip;

end;

end;

WSACleanup;

end;

(17).取得计算机名。

function tform1.get_name:string;

var ComputerName: PChar; size: DWord;

begin

GetMem(ComputerName,255);

size:=255;

if GetComputerName(ComputerName,size)=False then

result:=''

else

result:=ComputerName;

FreeMem(ComputerName);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

label1.Caption:=get_name;

end;

(18).取得硬盘序列号。

function tform1.GetHDSerialNumber: LongInt;

{$IFDEF WIN32}

var

pdw : pDWord;

mc, fl : dword;

{$ENDIF}

begin

{$IfDef WIN32}

New(pdw);

GetVolumeInformation('c:\',nil,0,pdw,mc,fl,nil,0);

Result := pdw^;

dispose(pdw);

{$ELSE}

Result := GetWinFlags;

{$ENDIF}

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

edit1.Text:=inttostr(gethdserialnumber);

end;

(19).限定光标移动范围。

procedure TForm1.Button1Click(Sender: TObject);

var

rect1:trect;

begin

rect1:=button2.BoundsRect;

mapwindowpoints(handle,0,rect1,2);

clipcursor(@rect1);

end;

procedure TForm1.Button2Click(Sender: TObject);

var

screenrect:trect;

begin

screenrect:=rect(0,0,screen.Width,screen.Height);

clipcursor(@screenrect);

end;

(20).限制edit框只能输入数字。

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);

begin

if not (key in ['0'..'9','.',#8]) then

begin

key:=#0;

Messagebeep(0);

end;

end;

(21).dbgrid中根据任一条件某一格变色。

procedure TForm_main.DBGridEh1DrawColumnCell(Sender: TObject;

const Rect: TRect; DataCol: Integer; Column: TColumnEh;

State: TGridDrawState);

begin

if (trim(DataModule1.ADOQuery1.FieldByName('dczt').AsString)='OK') then

begin

if datacol=6 then

begin

DbGrideh1.Canvas.Brush.Color:=clGradientActiveCaption;

DbGrideh1.DefaultDrawColumnCell(Rect,datacol,column,state);

end;

end;

end;

(22).打开word文件。

procedure TfjfsglForm.SpeedButton4Click(Sender: TObject);

var

MSWord: Variant;

str:string;

begin

if trim(DataModule1.adoquery27.fieldbyname('fjmc').asstring)<>'' then

begin

str:=trim(DataModule1.ADOQuery27.fieldbyname('fjmc').AsString);

MSWord:= CreateOLEObject('Word.Application');//

MSWord.Documents.Open('d:\Program Files\Common Files\Sfa\'+str, True);//

MSWord.Visible:=1;//

str:='';

MSWord.ActiveDocument.Range(0, 0);//

MSWord.ActiveDocument.Range.InsertAfter(str);//?úWord?D???ó×?·?'Title'

MSWord.ActiveDocument.Range.InsertParagraphAfter;

end

else

showmessage('');

end;

(23).word文件传入和传出数据库。

uses IdGlobal;

procedure TdjhyForm.SpeedButton2Click(Sender: TObject);

var

sfilename:string;

function BlobContentTostring(const Filename:string):string;

begin

with Tfilestream.Create(filename,fmopenread) do

try

setlength(result,size);

read(pointer(result)^,size);

finally

free;

end;

end;

begin

if opendialog1.Execute then

begin

sfilename:=opendialog1.FileName;

DataModule1.ADOQuery14.Edit;

DataModule1.ADOQuery14.FieldByName('word').AsString:=blobcontenttostring(sfilename);

DataModule1.ADOQuery14.Post;

end;

end;

procedure TdjhyForm.SpeedButton1Click(Sender: TObject);

var

sfilename:string;

bs:Tadoblobstream;

begin

bs:=Tadoblobstream.Create(TBLOBfield(DataModule1.ADOQuery14.FieldByName('word')),bmread);

try

sfilename:=extractfilepath(application.ExeName)+trim(DataModule1.adoquery14.fieldbyname('hybh').AsString);

sfilename:=sfilename+'.'+'doc';

bs.SaveToFile(sfilename);

try

djhyopenform:=Tdjhyopenform.Create(self);

djhyopenform.olecontainer1.CreateObjectFromFile(sfilename,false);

djhyopenform.OleContainer1.Iconic:=true;



教程录入:admin    责任编辑:admin 
  • 发表评论
  • 加入收藏
  • 加入QQ书签
  • 关闭页面
  • 您可能对以下教程还有兴趣:
    网友评论(评论内容只代表网友观点,与本站立场无关!)
    • 在线咨询
    • QQ:306826066
    • QQ:281788421
    • 旺旺客服
    • 技术支持
    • 售后服务
    爱毕业设计网