BVB Source Codes

Children's mathematical arithmetic software in Delphi source code Show Untfun.pas Source code

Return Download Children's mathematical arithmetic software in Delphi source code: download Untfun.pas Source code - Download Children's mathematical arithmetic software in Delphi source code Source code - Type:.pas
  1. unit Untfun;
  2.  
  3. interface
  4.  
  5.  uses
  6.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  7.   Dialogs, ImgList, ExtCtrls, ComCtrls, ToolWin,WinSock,StdCtrls, jpeg,
  8.   REGISTRY,ComObj, WordXP,inifiles,Math,ActiveX,ShlObj;
  9.  
  10.  
  11.   const
  12.  
  13.   // 公共信息
  14. {$IFDEF GB2312}
  15.   SCnInformation = '提示';
  16.   SCnWarning = '警告';
  17.   SCnError = '错误';
  18. {$ELSE}
  19.   SCnInformation = 'Information';
  20.   SCnWarning = 'Warning';
  21.   SCnError = 'Error';
  22. {$ENDIF}
  23.  
  24.   C1=52845; //字符串加密算法的公匙
  25.   C2=22719; //字符串加密算法的公匙
  26.  
  27.  
  28.  
  29. //▎================1、扩展的MDI有关操作函数  ===================▎//
  30.  
  31.   procedure OpenChildForm(FormClass: TFormClass; var Fm; AOwner:TComponent);
  32.   procedure OpenForm(FormClass: TFormClass; var fm; AOwner: TComponent);
  33.  
  34.   function IsForm(formClass:TFormClass) : boolean; //判断指定窗口存在没有
  35.   function isapprun(str:string):boolean;//判断指定程序运行没有
  36.   function CloseApp(ClassName: String): Boolean;   //关闭外部应用程序
  37.  
  38. //▎================2、扩展的网络有关操作函数  ===================▎//
  39.  
  40.  
  41.  
  42.   function GetHostIP:string;   {* 获取计算机的IP地址}
  43.   function GetComputerName:string;  {* 获取网络计算机名称}
  44.   function GetCurrentUserName : string;  //*获取当前Windows登录名的用户
  45.  
  46.  
  47. //▎================3、 扩展的注册有关操作函数  ===================▎//
  48.  
  49.   function getzcm:string;
  50.   function readzcm_ini(s:string):Integer ;
  51.   function writezcm_ini(i:Integer;s:string):Boolean ;
  52.   function readzcm_reg(s:string):integer;
  53.   function writezcm_reg(s:string):Boolean;
  54.  
  55.   function GetHDNumber(Drv : String): DWORD; //得到硬盘序列号
  56.   function Serial(Num:DWORD):string; //这个号码是用户给你生成注册码的,它通过对硬盘序列号编码而来。
  57.  
  58.   function StrToHex(AStr: string): string; {* 字符转化成十六进制}
  59.   function HexToStr(AStr: string): string; {* 十六进制转化成字符}
  60.   function TransChar(AChar: Char): Integer;
  61.  
  62.   function Encrypt(const S: String; Key: Word): String;//字符串加密函数
  63.   function Decrypt(const S: String; Key: Word): String; //字符串解密函数
  64.  
  65.  //▎================4、 扩展的文件路径函数  ===================▎//
  66.  
  67.  function PathWithSlash(const Path: string): string;
  68.  {功能,将路径变为带\符号的路径}
  69.  
  70.  function PathGetWindowsPath: string;  //WINDOWS路径\
  71.  function PathGetSystemPath: string;   //SYSTEM32路径\
  72.  function getsyspath:string;          //SYSTEM路径\
  73.  function getAppPath : string;        //程序路径   带"\"
  74.  function GetTempDirectory: String;    //临时目录\
  75.  
  76.  function shFileCopy(srcFile,destFile:String;bDelDest:boolean=true):boolean;// 功能:安全的复制文件
  77.   { 功能:安全的复制文件 ,srcFile,destFile:源文件和目标文件 ,
  78.  bDelDest:如果目标文件已经存在,是否覆盖 ,返回值:true成功,false失败}
  79.  
  80.  procedure DelTree(DirName:String);
  81.  {如C:\123  或C:\123\都行,内部会补齐 }
  82.  
  83.  function EmptyDirectory(TheDirectory :String ; Recursive : Boolean):Boolean;
  84.  {删除目录内的文件和子目录;如:"C:\123\" }
  85.  
  86.  procedure creatdesktoplink(Linkname:string);
  87.  {建立桌面快捷方式,Linkname为在桌面上要显示的字符}
  88.  
  89.  
  90. //▎================5 扩展的字符串操作函数  ===================▎//
  91.  
  92. function InStr(const sShort: string; const sLong: string): Boolean;     {测试通过}
  93. {* 判断s1是否包含在s2中}
  94.  
  95. function IntToStrEx(Value: Integer; Len: Integer; FillChar: Char = '0'): string;  {测试通过}
  96. {* 扩展整数转字符串函数  Example:   IntToStrEx(1,5,'0');   返回:"00001"}
  97.  
  98. function IntToStrSp(Value: Integer; SpLen: Integer = 3; Sp: Char = ','): string;  {测试通过}
  99. {* 带分隔符的整数-字符转换}
  100.  
  101. function ByteToBin(Value: Byte): string; {测试通过}
  102. {* 字节转二进制串}
  103.  
  104. function StrRight(Str: string; Len: Integer): string;  {测试通过}
  105. {* 返回字符串右边的字符   Examples: StrRight('ABCEDFG',3);   返回:'DFG' }
  106.  
  107. function StrLeft(Str: string; Len: Integer): string; {测试通过}
  108. {* 返回字符串左边的字符}
  109.  
  110. function Spc(Len: Integer): string;  {测试通过}
  111. {* 返回空格串}
  112.  
  113. function Replace(Str,s1,s2:string;CaseSensitive:Boolean):string;  {测试通过}
  114. {* 返回将指定字符s1用字符串s2替换后的字符串,可支持大小写敏感由CaseSensitive操作}
  115. {example: replace('We know what we want','we','I',false) = 'I Know what I want'}
  116.  
  117. function Replicate(pcChar:Char; piCount:integer):string;
  118. {在一个字符串中查找某个字符串的位置}
  119.  
  120. function StrNum(ShortStr:string;LongString:string):Integer;     {测试通过}
  121. {* 返回某个字符串中某个字符串中出现的次数}
  122.  
  123.  
  124. function PadLStr(psInput:String; piWidth:Integer; pcPadWith:Char):String;        {测试通过}
  125. {* 返回从psInput字符串左边开始用pcPadWith填充后总长度为PiWidth的字符串}
  126.  
  127. function PadRStr(psInput:String; piWidth:Integer; pcPadWith:Char):String;       {测试通过}
  128. {* 返回从psInput字符串右边开始用pcPadWith填充后总长度为PiWidth的字符串}
  129.  
  130. function PadCStr(psInput:String; piWidth:Integer; pcPadWith:Char):String;        {测试通过}
  131. {* 返回从psInput字符串两边开始用pcPadWith填充后总长度为PiWidth的字符串}
  132.  
  133. function ChrTran(psInput:String; pcSearch:Char; pcTranWith:Char):String;        {测试通过}
  134. {* 返回替换后字符串[替换单个字符] Examples: ChrTran('abCdEgdlkh','d','#'); 返回'abC#Eg#lkh'}
  135.  
  136. function StrTran(psInput:String; psSearch:String; psTranWith:String):String;        {测试通过}
  137. {* 返回替换后字符串[替换字符串] Examples: StrTran('aruyfbn','ruy','=====');; 返回'a=====fbn'}
  138.  
  139. function Stuff(psInput:String; piBeginPlace,piCount:Integer; psStuffWith:String):String;
  140. { *返回替换后字符串[替换字符串] Examples: Stuff('ABCDEFGHI',3,4,'12345');返回'AB12345GHI'}
  141.  
  142. function IsDigital(Value: string): boolean;
  143. {功能说明:判断string是否全是数字}
  144.  
  145. function RandomStr(aLength : Longint) : String;
  146. {随机字符串函数}
  147.  
  148. procedure TxttoWords(const S: string; words: TstringList);  
  149. {功能说明:分解成单个汉字,没有乱码,测试通过}
  150.  
  151. function tx(i: integer): string;      
  152. {功能说明:将数字变成汉字,如1变一}
  153.  
  154.  //==================================== 自定义的字符串
  155.   function deleleftdot(str:string):string;   //删除行首点号
  156.   function deleleftdun(str:string):string; //删除行首顿号
  157.   function deleleftdigital(str:string;partstr:string):string;
  158.  
  159.   function replacing(S,source,target:string):string;  
  160.   {功能:在S中用target来替换source,能够完全去除}
  161.  
  162.   function balancerate(source,target:string;pdxz:Boolean):Real;
  163.   {功能:计算两个字体符相同的经率,pdxz为是不是判断选择,处理时有差别,自定义}
  164.  
  165.  //以下为    处理时间
  166.  function TimeToSecond(const H, M, S: Integer): Integer;
  167.  function TimeSecondToTime(const secs: Integer):string;
  168.  //▎================6 扩展的WORD操作函数  ===================▎//
  169.  
  170.  function CONNECTWORD: Boolean;
  171.  {功能:建立、连接}
  172.  
  173.  procedure addstrtoword(text:string;align:Boolean;fontname:WideString;fontsize:integer);
  174.  {向WORD中追加字符,顺序为追加内容、对齐方式、字体、字体大小}
  175.  
  176.  procedure Addbmptoword(STR:string);
  177.  {功能:向WORD加入图片,STR为文件路径}
  178.  
  179.  procedure addstrtorich(s, fontname: string; fontsize,alimen: Integer; Richedit: TRichEdit);
  180.  {功能:向RICHEDIT控件中追加内容,顺序为内容、字体、字体大小、对齐方式(O为左,1为中,2为中)、控件NAME}
  181.  
  182.  procedure  loadpicture(str:string;var image:TImage);
  183.  {功能:打开图像文件,STR为路役,IMAGE为显示的控件}
  184.  
  185.  //▎================7 扩展的读取皮肤文件的函数  ===================▎//
  186.   function  readskinfile(Keyname:string):string;
  187.   {功能,读出皮肤路役,Keyname一般可设为程序名称,以利识别}
  188.  
  189.   procedure writeskinfile(keyname,filename:string);
  190.   {功能,写入皮肤路役,Keyname一般可设为程序名称,以利识别}
  191.  
  192. //===================8.ado===========
  193.   function setadoaccess(mdbpath:string;passwd:string):string;
  194.   // 加入字体
  195.  
  196.  
  197.  
  198.  var
  199.    msword: Variant;
  200.  
  201.  
  202.   implementation
  203.  
  204. procedure OpenChildForm(FormClass: TFormClass; var Fm; AOwner:TComponent);
  205. var
  206.   I: Integer;
  207.   Child: TForm;
  208. begin
  209.   for I := 0 to Screen.FormCount - 1 do
  210.    if Screen.Forms[I].ClassType = FormClass then
  211.      begin
  212.        Child := Screen.Forms[I];
  213.        if Child.WindowState = wsMinimized then
  214.        ShowWindow(Child.Handle, SW_SHOWNORMAL)
  215.        else
  216.        ShowWindow(Child.handle,SW_SHOWNA);
  217.        if (not Child.Visible) then Child.Visible := True;
  218.         Child.BringToFront;
  219.         Child.Setfocus;
  220.         TForm(Fm) := Child;
  221.         Exit;
  222.      end;
  223.     Child := TForm(FormClass.NewInstance);
  224.     TForm(Fm) := Child;
  225.     Child.Create(AOwner);
  226. end;
  227.  
  228.  
  229. procedure OpenForm(FormClass: TFormClass; var fm; AOwner: TComponent);
  230. var
  231.   i: integer;
  232.   Child: TForm;
  233. begin
  234.   for i := 0 to Screen.FormCount - 1 do
  235.     if screen.Forms[i].Owner = Aowner then
  236.      begin
  237.         //如有一窗口打开,将不打开新的窗口
  238.         if Screen.Forms[i].ClassType = FormClass then
  239.           begin
  240.             Child := Screen.Forms[i];
  241.             if Child.WindowState = wsMinimized then    //如已存在但最少化的窗口,将还原显示
  242.             ShowWindow(Child.handle, SW_SHOWNORMAL)
  243.             else
  244.             ShowWindow(Child.handle, SW_SHOWNA);
  245.             if (not Child.Visible) then Child.Visible := True;
  246.             Child.BringToFront;
  247.             Child.Setfocus;
  248.             TForm(fm) := Child;
  249.             exit;
  250.           end;
  251.  
  252.       exit;
  253.    end;
  254.  
  255.  
  256.   Child := TForm(FormClass.NewInstance);
  257.   TForm(fm) := Child;
  258.   Child.Create(AOwner);
  259. end;
  260.  
  261. function readzcm_reg(s:string):integer;
  262. var
  263.   re_id:integer;
  264.   registerTemp : TRegistry;
  265.   re_code:string;
  266.   ini_num:Integer;
  267.   Temres:Integer;
  268. begin
  269.   Temres:=0;
  270.   registerTemp := TRegistry.Create;
  271.     with registerTemp do
  272.     begin
  273.       RootKey:=HKEY_LOCAL_MACHINE;
  274.        try
  275.        if OpenKey('Software\Microsoft\Windows\'+s,True) then// 建一目录
  276.           begin                               //wwwwwwwwwwwwwwwww
  277.             if ValueExists('reg_code') then  //如存在则
  278.             begin
  279.               re_code:=ReadString('reg_code');
  280.               if re_code=getzcm then Temres:=0;// 己注册
  281.             end
  282.             else
  283.             begin  //如果注册码键值不存在      //eeeeeeeeeeeee
  284.  
  285.               ini_num:=readzcm_ini('xlxt');   //读出INI记录的运行次数
  286.  
  287.               //往下语句肯定是非注册用户
  288.               if valueexists('gc_id')=False then   //如NOT存在则
  289.               begin //判断其存在否?     //ggggggggggggggg
  290.                 if ini_num =0 then
  291.                 begin
  292.                   Writeinteger('gc_id',1);//如不存在则建立
  293.                   writezcm_ini(1,'xlxt');
  294.                   Temres:=1;
  295.                 end
  296.                 else
  297.                 Writeinteger('gc_id',ini_num);
  298.               END                     //gggggggggggggg
  299.               else
  300.               begin //判断其存在否?   rrrrrrrrrrrrrrrrrr
  301.                 re_id:=readinteger('gc_id');//读出标志值
  302.                 re_id:=max(re_id,ini_num);
  303.                 if (re_id>500) or (re_id<1) then  Temres :=1000//假如1000,则应注册。
  304.                 else
  305.                 begin
  306.                   re_id:=re_id+1; //最大值为500 ,试用期
  307.                   Writeinteger('gc_id',re_id);
  308.                   writezcm_ini(re_id,'xlxt');
  309.                   Temres :=re_id;
  310.                 end;
  311.               end;  //IF  EXSIT      rrrrrrrrrrrrrrrrrrrr
  312.          end;//如果键值不存在        eeeeeeeeeeeeeeeeeeee
  313.        end;    //      wwwwwwwwwww
  314.        
  315.      finally
  316.      CloseKey;
  317.      Free;
  318.    end;
  319.  Result :=Temres;
  320. end; //with registerTemp do
  321.  
  322. end;
  323.  
  324.  
  325. function writezcm_reg(s:string):Boolean;
  326. VAR
  327.   REG:TREGISTRY;
  328.   str:string;
  329. begin
  330.    Result :=False;
  331.    str:=getzcm;
  332.    REG:=TREGISTRY.Create ;
  333.       WITH REG DO
  334.         BEGIN
  335.           ROOTKEY:=HKEY_LOCAL_MACHINE;
  336.           TRY
  337.           if OpenKey('Software\Microsoft\Windows\'+s,True) then
  338.             begin
  339.               WriteString('reg_code',str);
  340.               Writeinteger('gc_id',0);//若输入的注册码正确,则将标志值置为0 即已注册。
  341.               Result :=True;
  342.             end;
  343.           FINALLY
  344.           CloseKey;
  345.           Free;
  346.           END;
  347.        end;
  348. end;
  349.  
  350. function getzcm:string;
  351. var
  352.   str,temstr:string;
  353.   i:Integer;
  354. begin
  355.   str:=Trim(Serial(GetHDNumber('C:')));
  356.   temstr:=Copy(str,1,10);
  357.   i:=Length(temstr);
  358.   if i<10 then temstr:=temstr+copy('luzhenfeng',1,10-i);
  359.   Result :=temstr ;
  360. end;
  361.  
  362. function readzcm_ini(s:string):Integer ;
  363. var
  364.   inifile:TIniFile ;
  365.   IniFileName:string;
  366.   num:Integer ;
  367. begin
  368.   IniFileName:= PathGetWindowsPath+'myset.ini' ;
  369.   inifile:=TInifile.Create(IniFileName);
  370.   try
  371.   num:=inifile.ReadInteger(s,'recorder',0);
  372.   finally
  373.   inifile.Free;
  374.   end;
  375.  
  376.   Result :=num;  
  377. end;
  378.  
  379. function writezcm_ini(i:integer;s:string):Boolean ;
  380. var
  381.   inifile:TIniFile ;
  382.   IniFileName:string;
  383.   BB:Boolean ;
  384. begin
  385.  
  386.   IniFileName:= PathGetWindowsPath+'myset.ini' ;
  387.   inifile:=TInifile.Create(IniFileName);
  388.   try
  389.     inifile.WriteInteger(s,'recorder',i);
  390.     BB :=True;
  391.   finally
  392.     inifile.Free ;
  393.   end;
  394.   result:=BB;
  395. end;
  396.  
  397.  //-------------------------------------  生成注册码
  398. function GetHDNumber(Drv : String): DWORD; //得到硬盘序列号
  399. var
  400.  VolumeSerialNumber : DWORD;
  401.  MaximumComponentLength : DWORD;
  402.  FileSystemFlags : DWORD;
  403. begin
  404.  if Drv[Length(Drv)] =':' then Drv := Drv + '\';
  405.  GetVolumeInformation(pChar(Drv),
  406.             nil,
  407.             0,
  408.             @VolumeSerialNumber,
  409.             MaximumComponentLength,
  410.             FileSystemFlags,
  411.             nil,
  412.             0);
  413.  Result:= (VolumeSerialNumber);
  414.  //GetVolumeInformation("C:\\",NULL,NULL,&dwIDESerial,NULL,NULL,NULL,NULL);
  415. end;
  416.  
  417. function Serial(Num:DWORD):string; //这个号码是用户给你生成注册码的,它通过对硬盘序列号编码而来。
  418. var sNum:string; inChar:array[1..4]of char;
  419. begin
  420.  
  421.  Num:=Num xor 8009211011;
  422.  sNum:=inttostr(Num);
  423.  inChar[1]:=char(((integer(sNum[1])+integer(sNum[2]))mod 5)+integer('a'));
  424.  inChar[2]:=char(((integer(sNum[3])+integer(sNum[4]))mod 5)+integer('a'));
  425.  inChar[3]:=char(((integer(sNum[5])+integer(sNum[6]))mod 5)+integer('a'));
  426.  inChar[4]:=char(((integer(sNum[7])+integer(sNum[8])+integer(sNum[9]))mod 5)+integer('a'));
  427.  insert(inChar[1],sNum,1);
  428.  insert(inChar[4],sNum,3);
  429.  insert(inChar[2],sNum,5);
  430.  insert(inChar[3],sNum,9);
  431.  Result:=sNum;
  432. end;
  433.  
  434. //▎======================⑾进制函数及过程======================▎//
  435.  
  436. function TransChar(AChar: Char): Integer;
  437. begin
  438.    if AChar in ['0'..'9'] then
  439.       Result := Ord(AChar) - Ord('0')
  440.    else
  441.       Result := 10 + Ord(AChar) - Ord('A');
  442.    end;
  443.  
  444.  
  445. //字符转化成十六进制
  446. function StrToHex(AStr: string): string;
  447. var
  448.    I : Integer;
  449. //   Tmp: string;
  450.    begin
  451.       Result := '';
  452.       For I := 1 to Length(AStr) do
  453.       begin
  454.          Result := Result + Format('%2x', [Byte(AStr[I])]);
  455.       end;
  456.       I := Pos(' ', Result);
  457.       While I <> 0 do
  458.       begin
  459.          Result[I] := '0';
  460.          I := Pos(' ', Result);
  461.       end;
  462. end;
  463.  
  464. //十六进制转化成字符
  465. function HexToStr(AStr: string): string;
  466. var
  467.    I : Integer;
  468.    CharValue: Word;
  469.    begin
  470.    Result := '';
  471.    for I := 1 to Trunc(Length(Astr)/2) do
  472.    begin
  473.       Result := Result + ' ';
  474.       CharValue := TransChar(AStr[2*I-1])*16 + TransChar(AStr[2*I]);
  475.       Result[I] := Char(CharValue);
  476.    end;
  477. end;
  478.  
  479. //▎======================字符串加密和解密======================▎//
  480.  
  481. //字符串加密函数
  482. function Encrypt(const S: String; Key: Word): String;
  483. var
  484.    I : Integer;
  485. begin
  486.       Result := S;
  487.       for I := 1 to Length(S) do
  488.       begin
  489.          Result[I] := char(byte(S[I]) xor (Key shr 8));
  490.          Key := (byte(Result[I]) + Key) * C1 + C2;
  491.          if Result[I] = Chr(0) then
  492.             Result[I] := S[I];
  493.       end;
  494.       Result := StrToHex(Result);
  495. end;
  496.  
  497.  
  498. //字符串解密函数
  499. function Decrypt(const S: String; Key: Word): String;
  500. var
  501.    I: Integer;
  502.    S1: string;
  503. begin
  504.    S1 := HexToStr(S);
  505.    Result := S1;
  506.    for I := 1 to Length(S1) do
  507.    begin
  508.       if char(byte(S1[I]) xor (Key shr 8)) = Chr(0) then
  509.          begin
  510.             Result[I] := S1[I];
  511.             Key := (byte(Chr(0)) + Key) * C1 + C2; //保证Key的正确性  
  512.          end
  513.       else
  514.          begin
  515.             Result[I] := char(byte(S1[I]) xor (Key shr 8));
  516.             Key := (byte(S1[I]) + Key) * C1 + C2;
  517.          end;
  518.    end;
  519. end;
  520. //==========================================     文件路径
  521. function PathWithSlash(const Path: string): string;       //带\符号
  522. begin
  523.  Result := Path;
  524.  if (Length(Result) > 0) and (Result[Length(Result)] <> '\') then Result := Result + '\';
  525. end;
  526.  
  527. function PathGetSystemPath: string;   //SYSTEM32路径
  528. var
  529.  Buf: array[0..255] of Char;
  530. begin
  531.  GetSystemDirectory(@Buf, 255);
  532.  Result := PathWithSlash(StrPas(@Buf));
  533. end;
  534.  
  535. function PathGetWindowsPath: string;  //WINDOWS路径
  536. var
  537.  Buf: array[0..255] of Char;
  538. begin
  539.  GetWindowsDirectory(@Buf, 255);
  540.  Result := PathWithSlash(StrPas(@Buf));
  541. end;
  542.  
  543. function getsyspath:string; //  注:MySysPath为SYSTEM路径
  544. var
  545. MySysPath : PCHAR ;
  546.   begin
  547.   GetMem(MySysPath,255);
  548.   GetSystemDirectory(MySysPath,255);
  549.   result:=PathWithSlash(strpas(mysyspath));
  550.  end;
  551.  
  552. function getAppPath : string;   //程序目录带\
  553. var
  554.   strTmp : string;
  555. begin
  556.   strTmp :=ExtractFilePath(application.Exename);
  557.   result := PathWithSlash(strTmp);
  558. end;
  559.  
  560. function GetTempDirectory: String;    //临时目录\
  561. var
  562. TempDir: array[0..255] of Char;
  563. begin
  564. GetTempPath(255, @TempDir);
  565. result:=PathWithSlash(strpas(TempDir));
  566. end;
  567.  
  568.  
  569. //▎============================================================▎//
  570. //▎==================①扩展的字符串操作函数====================▎//
  571. //▎============================================================▎//
  572.  // 判断s1是否包含在s2中
  573. function InStr(const sShort: string; const sLong: string): Boolean;
  574. var
  575.   s1, s2: string;
  576. begin
  577.   s1 := LowerCase(sShort);
  578.   s2 := LowerCase(sLong);
  579.   Result := Pos(s1, s2) > 0;
  580. end;
  581.  
  582. // 扩展整数转字符串函数,参数分别为目标数、长度、填充字符(默认为0)
  583. function IntToStrEx(Value: Integer; Len: Integer; FillChar: Char = '0'): string;
  584. begin
  585.   Result := IntToStr(Value);
  586.   while Length(Result) < Len do
  587.     Result := FillChar + Result;
  588. end;
  589.  
  590. // 带分隔符的整数-字符转换
  591. function IntToStrSp(Value: Integer; SpLen: Integer = 3; Sp: Char = ','): string;
  592. var
  593.   s: string;
  594.   i, j: Integer;
  595. begin
  596.   s := IntToStr(Value);
  597.   Result := '';
  598.   j := 0;
  599.   for i := Length(s) downto 1 do
  600.   begin
  601.     Result := s[i] + Result;
  602.     Inc(j);
  603.     try
  604.        if ((j mod SpLen) = 0) and (i <> 1) then
  605.           Result := Sp + Result;
  606.     except
  607.        MessageBox(Application.Handle,' IntToStrSp函数的第二个参数值不能为数字0 !',SCnError,16);
  608.        exit;
  609.     end
  610.   end;
  611. end;
  612.  
  613. // 返回字符串右边的字符
  614. function StrRight(Str: string; Len: Integer): string;
  615. begin
  616.   if Len >= Length(Str) then
  617.     Result := Str
  618.   else
  619.     Result := Copy(Str, Length(Str) - Len + 1, Len);
  620. end;
  621.  
  622. // 返回字符串左边的字符
  623. function StrLeft(Str: string; Len: Integer): string;
  624. begin
  625.   if Len >= Length(Str) then
  626.     Result := Str
  627.   else
  628.     Result := Copy(Str, 1, Len);
  629. end;
  630.  
  631. // 字节转二进制串
  632. function ByteToBin(Value: Byte): string;
  633. const
  634.   V: Byte = 1;
  635. var
  636.   i: Integer;
  637. begin
  638.   for i := 7 downto 0 do
  639.     if (V shl i) and Value <> 0 then
  640.       Result := Result + '1'
  641.     else
  642.       Result := Result + '0';
  643. end;
  644.  
  645. // 返回空格串
  646. function Spc(Len: Integer): string;
  647. var
  648.   i: Integer;
  649. begin
  650.   Result := '';
  651.   for i := 0 to Len - 1 do
  652.     Result := Result + ' ';
  653. end;
  654.  
  655. // 返回将指定字符s1用字符串s2替换后的字符串,可支持大小写敏感由CaseSensitive操作}
  656. function Replace(Str,s1,s2:string;CaseSensitive:Boolean):string;
  657. var
  658.    i:integer;
  659.    s,t:string;
  660. begin
  661.    s:='';
  662.    t:=str;
  663.    repeat
  664.       if casesensitive then
  665.          i:=pos(s1,t)
  666.       else
  667.          i:=pos(lowercase(s1),lowercase(t));
  668.          if i>0 then
  669.             begin
  670.                s:=s+Copy(t,1,i-1)+s2;
  671.                t:=Copy(t,i+Length(s1),MaxInt);
  672.             end
  673.          else
  674.             s:=s+t;
  675.    until i<=0;
  676.    result:=s;
  677. end;
  678.  
  679. function Replicate(pcChar:Char; piCount:integer):string;
  680. begin
  681.         Result:='';
  682.         SetLength(Result,piCount);
  683.         fillChar(Pointer(Result)^,piCount,pcChar)
  684. end;
  685.  
  686. // 返回某个字符串中某个字符串中出现的次数}
  687. function StrNum(ShortStr:string;LongString:string):Integer;     {测试通过}
  688. var
  689.    i:Integer;
  690. begin
  691.    i:=0;
  692.    while pos(ShortStr,LongString)>0 do
  693.       begin
  694.          i:=i+1;
  695.          LongString:=Copy(LongString,(pos(ShortStr,LongString))+1,Length(LongString)-pos(ShortStr,LongString))
  696.       end;
  697.    Result:=i;
  698. end;
  699.  
  700.  
  701. {* 返回从psInput字符串左边开始用pcPadWith填充后总长度为PiWidth的字符串}
  702. function PadLStr(psInput:String; piWidth:Integer; pcPadWith:Char):String;
  703. begin
  704.         Result:=Replicate(pcPadWith,piWidth-Length(psInput))+psInput
  705. end;
  706.  
  707. {* 返回从psInput字符串右边开始用pcPadWith填充后总长度为PiWidth的字符串}
  708. function PadRStr(psInput:String; piWidth:Integer; pcPadWith:Char):String;
  709. begin
  710.         Result:=psInput+Replicate(pcPadWith,piWidth-Length(psInput))
  711. end;
  712.  
  713. {* 返回从psInput字符串两边开始用pcPadWith填充后总长度为PiWidth的字符串}
  714. function PadCStr(psInput:String; piWidth:Integer; pcPadWith:Char):String;
  715. var
  716.         liHalf :integer;
  717. begin
  718.         liHalf:=(piWidth-Length(psInput))div 2;
  719.         Result:=Replicate(pcPadWith,liHalf)+psInput+Replicate(pcPadWith,piWidth-Length(psInput)-liHalf)
  720. end;
  721.  
  722. {* 返回替换后字符串 Examples: ChrTran('abCdEgdlkh','d','#'); 返回'bC#Eg#lkh'}
  723. function ChrTran(psInput:String; pcSearch:Char; pcTranWith:Char):String;
  724. var
  725.         i,j:integer;
  726. begin
  727.         j:=Length(psInput);
  728.         for i:=1 to j do
  729.   begin
  730.                 if psInput[i]=pcSearch then
  731.                         psInput[i]:=pcTranWith
  732.   end;
  733.         Result:=psInput
  734. end;
  735.  
  736. {* 返回替换后字符串 Examples: StrTran('aruyfbn','ruy','====='); 返回'a=====fbn'}
  737. function StrTran(psInput:String; psSearch:String; psTranWith:String):String;
  738. var
  739.         liPosition,liLenOfSrch,liLenOfIn:integer;
  740. begin
  741.         liPosition:=Pos(psSearch,psInput);
  742.         liLenOfSrch:=Length(psSearch);
  743.         liLenOfIn:=Length(psInput);
  744.         while liPosition>0 do
  745.         begin
  746.                 psInput:=Copy(psInput,1,liPosition-1)
  747.                         +psTranWith
  748.       +Copy(psInput,liPosition+liLenOfSrch,liLenOfIn);
  749.                 liPosition:=Pos(psSearch,psInput)
  750.         end;
  751.         Result:=psInput
  752. end;
  753.  
  754. { *返回替换后字符串[替换字符串] Examples: Stuff('ABCDEFGHI',3,4,'12345');返回'AB12345GHI'}
  755. function Stuff(psInput:String; piBeginPlace,piCount:Integer; psStuffWith:String):String;
  756. begin
  757.         Result:=Copy(psInput,1,piBeginPlace-1)+
  758.                 psStuffWith+
  759.     Copy(psInput,piBeginPlace+piCount,Length(psInput))
  760. end;
  761.  
  762.  
  763. {功能说明:判断string是否全是数字}
  764. function IsDigital(Value: string): boolean;
  765. var
  766.   i, j: integer;
  767.   str: char;
  768. begin
  769.   result := true;
  770.   Value := trim(Value);
  771.   j := Length(Value);
  772.   if j = 0 then
  773.   begin
  774.     result := false;
  775.     exit;
  776.   end;
  777.   for i := 1 to j do
  778.   begin
  779.     str := Value[i];
  780.     if not (str in ['0'..'9']) then
  781.     begin
  782.       result := false;
  783.       exit;
  784.     end;
  785.   end;
  786. end;
  787.  
  788. {随机字符串函数}
  789. function RandomStr(aLength : Longint) : String;
  790. var
  791.   X : Longint;
  792. begin
  793.   if aLength <= 0 then exit;
  794.   SetLength(Result, aLength);
  795.   for X:=1 to aLength do
  796.     Result[X] := Chr(Random(26) + 65);
  797. end;
  798.  
  799.  
  800. //=============================================
  801.  
  802. function tx(i: integer): string;
  803. begin
  804.  case i of
  805.  0:RESULT:='一';
  806.  1:RESULT:='二';
  807.  2:result:='三';
  808.  3:result:='四';
  809.  4:result:='五';
  810.  5:result:='六';
  811.  6:result:='七';
  812.  7:result:='八';
  813.  8:result:='九';
  814.  9:result:='十';
  815.   ELSE
  816.    result:='太多了';
  817.  end;
  818.  
  819. end;
  820.  
  821.  
  822. function deleleftdigital(str:string;partstr:string):string;
  823. var
  824.   i,j:integer  ;
  825.   s:string;
  826. begin
  827.  
  828.   j:=Length(partstr);
  829.  
  830.   i:=pos(partstr,str);
  831.   s:=StrLeft(str,i-1);
  832.  
  833.   if IsDigital(s) then
  834.   begin
  835.     if j=1 then delete(str,1,i)
  836.     else
  837.     Delete(str,1,i+j-1)
  838.   end;
  839.   result:=trim(str);
  840. end;
  841.  
  842.  
  843. function deleleftdot(str:string):string; //删除行首点号
  844. var
  845.   I:integer  ;
  846.   s:string;
  847. begin
  848.   str:=Trim(str);
  849.   i:=pos('.',str);
  850.   s:=StrLeft(str,i-1);
  851.  
  852.   if IsDigital(s) then delete(str,1,i);
  853.   result:=trim(str);
  854. end;
  855.  
  856. function deleleftdun(str:string):string;    //删除行首顿号
  857. var
  858.   I:integer  ;
  859.   s:string;
  860. begin
  861.   str:=Trim(str);
  862.   i:=pos('、',str);
  863.   s:=StrLeft(str,i-1);
  864.  
  865.   if IsDigital(s) then delete(str,1,i+1);  // 顿号是2个字节
  866.   result:=trim(str);
  867. end;
  868.  
  869.  //字符串处理,分成单个字,没有乱码
  870. procedure TxttoWords(const S: string; words: TstringList);
  871. var
  872.   j:Integer ;
  873.   sCuted{ 按固定长度分割出来的部分字符串 }: string;
  874.   iCutLength{ 按固定长度分割出来的部分字符串的长度 }: integer;
  875.   bIsDBCS{ 是否是汉字的前半字节 }: boolean;
  876.   sline:string;
  877. begin
  878.   sline:=s;
  879.   if Length(sline)=0 then words.Add(#13#10)
  880.   else
  881.   repeat ;
  882.   iCutLength :=2;
  883.   sCuted :=Copy(sline,1,iCutLength );
  884.   bIsDBCS:=False ;
  885.   for j:=1 to icutlength do
  886.     begin
  887.       if bIsDBCS then
  888.         bIsDBCS :=False
  889.         else
  890.           if Windows.IsDBCSLeadByte(Byte(sCuted[j])) then
  891.             bIsDBCS :=True;
  892.  
  893.     end; //end of for
  894.  
  895.     if bIsDBCS then Dec(iCutLength);
  896.     if Copy(sline,1,iCutLength)<>#13#10 then   //去除回车
  897.     words.Add(Copy(sline,1,iCutLength));
  898.     sline :=Copy(sline,iCutLength +1,Length(sline )-icutlength);
  899.     until Length (sline)<=0 ;
  900. end;
  901.  
  902. function replacing(S,source,target:string):string;    //完全去除
  903. var
  904.   site,StrLen:integer;
  905. begin
  906.   {source在S中出现的位置}
  907.   site:=pos(source,s);
  908.   {source的长度}
  909.   StrLen:=length(source);
  910.   {删除source字符串}
  911.   delete(s,site,StrLen);
  912.   {插入target字符串到S中}
  913.   insert(target,s,site);
  914.  {返回新串}
  915.  
  916.  site:=pos(source,s);
  917.   IF site >0 then
  918.       S:=replacing(S,source,target) ;
  919.   Result :=S;
  920. end;
  921.  
  922.  function balancerate(source,target:string;pdxz:Boolean):Real;
  923.  var
  924.    str1,str2:string;
  925.    sourcelist,targetlist: TstringList;
  926.    i,df:Integer;
  927.    Temstr:string;
  928.    maxcount:Integer ;
  929.  begin
  930.    source :=Trim(source);    //去除前后空格
  931.    target :=Trim(target);
  932.  
  933.    if Trim(source)=Trim(target ) then    //   如果相等就对了
  934.       begin
  935.         Result :=1;
  936.         Exit;
  937.       end;
  938.  
  939.    source:=replacing(source,',',''); //去除逗号
  940.    source:=replacing(source,',','');  //去除半角,
  941.    source:=replacing(source,'。',''); //去除句号
  942.    source:=replacing(source,'?',''); //去除问号
  943.    source:=replacing(source,':',''); //去除:
  944.    source:=replacing(source,':','');  //去除半角:
  945.    source:=replacing(source,';','');  //去除分号
  946.    source:=replacing(source,';','');  //去除半角分号
  947.    source:=replacing(source,' ','');  //去除空格
  948.    source:=replacing(source,'《','');  //去除书引号
  949.    source:=replacing(source,'》','');  //去除书引号
  950.  
  951. //=======================
  952.    target:=replacing(target,',',''); //去除逗号
  953.    target:=replacing(target,',','');  //去除半角,
  954.    target:=replacing(target,'。',''); //去除句号
  955.    target:=replacing(target,'?',''); //去除问号
  956.    target:=replacing(target,':',''); //去除:
  957.    target:=replacing(target,':','');  //去除半角:
  958.    target:=replacing(target,';','');  //去除分号
  959.    target:=replacing(target,';','');  //去除半角分号
  960.    target:=replacing(target,' ','');  //去除空格
  961.    target:=replacing(target,'《','');  //去除书引号
  962.    target:=replacing(target,'》','');  //去除书引号
  963.  
  964.  
  965.     if Trim(source)=Trim(target ) then    //   去除符号后如果相等就对了
  966.       begin
  967.         Result :=1;
  968.         Exit;
  969.       end;
  970.  
  971.      df :=0;
  972.      
  973.   if pdxz then  //if is 判断\选择题则
  974.     begin
  975.       target:=replacing(target,'.','');  //去除.
  976.       source:=replacing(source,'.','');  //去除.
  977.  
  978.         // source代表答案,targe代表答的答题
  979.        if Length(target)>Length(source) then
  980.         begin
  981.           Result :=0 ; //多选不得分;
  982.           Exit;
  983.         end;
  984.  
  985.       str2:=target;
  986.         for i:=1 to Length(source) do
  987.           begin
  988.             str1:=Copy(source,i,1) ;
  989.             if InStr(str1,str2) then
  990.             df:=df+1;  //计算对的个数
  991.           end;
  992.  
  993.       Result :=df/length(source);
  994.    
  995.      end//如果不是判断/选择题
  996.      else
  997.      begin
  998.        sourcelist :=TStringList.Create ;
  999.        targetlist :=TStringList.Create ;
  1000.        TxttoWords(source,sourcelist);
  1001.        TxttoWords(target,targetlist);
  1002.  
  1003.         if sourcelist.Count >targetlist.Count then
  1004.         maxcount :=sourcelist.Count
  1005.         else
  1006.         maxcount :=targetlist.Count ;//最大值
  1007.  
  1008.  
  1009.        str2 :=target ;
  1010.        for i:=0 to sourcelist.Count -2 do
  1011.          begin
  1012.            Temstr:=sourcelist.Strings[i+1];
  1013.            str1:=sourcelist.Strings[i]+temstr;
  1014.            if InStr(str1,str2) then
  1015.               df:=df+1;
  1016.          end;
  1017.  
  1018.        if df>0 then df:=df+1;
  1019.        Result :=df/maxcount;        //输出结果
  1020.        // Result :=df/sourcelist.count;
  1021.       sourcelist.Free ;  //清除内存
  1022.       targetlist.Free ;
  1023.      end;
  1024.  
  1025. end;
  1026.  
  1027.  
  1028.  
  1029. //=========================
  1030. function IsForm(FormClass: TFormClass) : boolean; //判断指定窗口存在没有
  1031. var
  1032. i : integer;
  1033. begin
  1034. result := False;
  1035. for i := 0 to screen.FormCount -1 do
  1036. begin
  1037. if (screen.Forms[i].ClassType = formClass) then
  1038. begin
  1039. result := True;
  1040. Break;
  1041. end;
  1042. end;
  1043. end;
  1044.  
  1045. function isapprun(str:string):boolean; //判断指定程序运行没有
  1046. var
  1047. HWndCalculator : HWnd;
  1048. begin
  1049. result:=false;
  1050.  
  1051. HWndCalculator := FindWindow(nil, pchar(str));
  1052. if HWndCalculator <> 0 then
  1053.     result:=true;
  1054.  
  1055. end;
  1056.  
  1057. function CloseApp(ClassName: String): Boolean;
  1058. //关闭外部应用程序
  1059. var Exehandle: THandle;
  1060. begin
  1061.   //ExeHandle := FindWindow(nil, Pchar(Caption));
  1062.   ExeHandle := FindWindow(Pchar(ClassName),nil);
  1063.   if ExeHandle <> 0
  1064.   then
  1065.    begin
  1066.      PostMessage(ExeHandle, WM_Quit, 0, 0);
  1067.      Result:=True;
  1068.    end
  1069.   else
  1070.    begin
  1071.      Result:=False;
  1072.    end;
  1073. end;
  1074.  
  1075.  
  1076. {* 获取计算机的IP地址}
  1077. function GetHostIP:string;
  1078. var
  1079.    wVersionRequested : WORD;
  1080.    wsaData : TWSAData;
  1081.    p : PHostEnt; s : array[0..128] of char; p2 : pchar;
  1082. begin
  1083.    try
  1084.       wVersionRequested := MAKEWORD(1, 1); //创建 WinSock
  1085.       WSAStartup(wVersionRequested, wsaData); //创建 WinSock
  1086.       GetHostName(@s,128);
  1087.       p:=GetHostByName(@s);
  1088.       p2 := iNet_ntoa(PInAddr(p^.h_addr_list^)^);
  1089.       Result:= P2;
  1090.    finally
  1091.       WSACleanup; //释放 WinSock
  1092.    end;
  1093. end;
  1094.  
  1095.  {* 获取网络计算机名称}
  1096. function GetComputerName:string;
  1097. var
  1098.    wVersionRequested : WORD;
  1099.    wsaData : TWSAData;
  1100.    p : PHostEnt; s : array[0..128] of char;
  1101. begin
  1102.    try
  1103.       wVersionRequested := MAKEWORD(1, 1); //创建 WinSock
  1104.       WSAStartup(wVersionRequested, wsaData); //创建 WinSock
  1105.       GetHostName(@s,128);
  1106.       p:=GetHostByName(@s);
  1107.       Result:=p^.h_Name;
  1108.    finally
  1109.       WSACleanup; //释放 WinSock
  1110.    end;
  1111. end;
  1112.  
  1113. //*获取当前Windows登录名的用户
  1114. function GetCurrentUserName : string;
  1115. const
  1116.    cnMaxUserNameLen = 254;
  1117. var
  1118.    sUserName : string;
  1119.    dwUserNameLen : Dword;
  1120. begin
  1121.    dwUserNameLen := cnMaxUserNameLen-1;
  1122.    SetLength( sUserName, cnMaxUserNameLen );
  1123.    GetUserName(Pchar( sUserName ), dwUserNameLen );
  1124.    SetLength( sUserName, dwUserNameLen );
  1125.    Result := sUserName;
  1126. end;
  1127.  
  1128. //===================================时间处理
  1129. function TimeToSecond(const H, M, S: Integer): Integer;
  1130. begin
  1131. Result := H * 3600 + M * 60 + S;
  1132. end;
  1133.  
  1134. function TimeSecondToTime(const secs: Integer):string;
  1135. var
  1136.   H, M, S: Word;
  1137. begin
  1138. H := secs div 3600;
  1139. M := (secs mod 3600) div 60;
  1140. S := secs mod 60;
  1141.  
  1142. Result :=format('%-.2d', [h])+':'+format('%-.2d', [m])+ ':'+format('%-.2d', [s]);
  1143.  
  1144. end;
  1145.  
  1146.  
  1147. function CONNECTWORD: Boolean;
  1148. var
  1149.   template:OleVariant ;
  1150.   newtemplate:OleVariant ;
  1151.   docutype:OleVariant ;
  1152.   visible:OleVariant ;
  1153.  
  1154. begin
  1155.   template:=EmptyParam ;
  1156.  // newtemplate :=TRUE;  //模板式
  1157.   //docutype:=0;   //模板式
  1158.    newtemplate :=False;
  1159.    docutype :=wdNewBlankDocument ;    //文档式
  1160.    visible :=True;
  1161.   try
  1162.    begin
  1163.     MSWord := CreateOLEObject('Word.Application');//连接Word
  1164.     msword.visible:=True;
  1165.     msword.Documents.Add(template,newtemplate,docutype ,visible );
  1166.     Result:=True;
  1167.     END;
  1168.   except
  1169.     begin
  1170.      application.MessageBox('Word文档连接失败','提示',MB_OK+  MB_ICONEXCLAMATION);
  1171.      Result :=False ;
  1172.      END;
  1173.   END;
  1174. end;
  1175.  
  1176.  
  1177. procedure addstrtoword(text:string;align:Boolean;fontname:WideString;fontsize:integer);
  1178. begin
  1179.   MSWord.Selection.Font.Size:=fontsize ;
  1180.   MSWord.Selection.Font.Name := fontname ;
  1181.   if  align then
  1182.   MSWord.Selection.ParagraphFormat.Alignment:= wdAlignParagraphCenter
  1183.   else
  1184.    BEGIN
  1185.    MSWord.Selection.ParagraphFormat.Alignment:= wdAlignParagraphLEFT;
  1186.    MSWord.Selection.ParagraphFormat.FirstLineIndent:=30;
  1187.    end;
  1188.  
  1189.   MSWord.Selection.TypeText(text);
  1190.   MSWord.Selection.TypeParagraph;
  1191. end;
  1192.  
  1193. procedure Addbmptoword(str:string );
  1194. begin  //str:图片绝对路径;
  1195.     msword.Selection.InlineShapes.AddPicture(str,False, True);
  1196. end;
  1197. {s:加入的字符;FONTNAME:字体名称,FONTSIZE:字体大小;ALIGENM:对齐方式0为左2为中1为右,RICHEDIT为加入对象的载体}
  1198.  
  1199. procedure addstrtorich(s, fontname: string; fontsize,alimen: Integer; Richedit: TRichEdit);
  1200. begin
  1201.   try
  1202.     Richedit.Lines.Add(s) ;
  1203.     Richedit.SelLength :=-length(s)-2;
  1204.     Richedit.SelAttributes.Size :=fontsize ;
  1205.     Richedit.SelAttributes.Name :=fontname ;
  1206.     Richedit.Paragraph.Alignment :=talignment(alimen) ;
  1207.   //  Richedit.SelStart:=Length(Richedit.Lines.Text);
  1208.   except
  1209.     Exit ;
  1210.   END;  
  1211. end;
  1212.  
  1213. //读取皮肤文件========================================================
  1214. function readskinfile(keyname:string):string;
  1215. var
  1216.  IniFileName:string;
  1217.  inifile:TInifile;
  1218.  str:string;
  1219.  ML:string;
  1220.  
  1221. begin
  1222.   ml:= getapppath+'ini';
  1223.   if Not DirectoryExists(ml) then CreateDir(ml);
  1224.  
  1225.   IniFileName:=getapppath+'ini\skin.ini';
  1226.   inifile:=TInifile.Create(IniFileName);
  1227.   str:=inifile.ReadString(Keyname,'skinfiles','');
  1228.   inifile.Free;
  1229.  
  1230.   Result :=str;
  1231.  
  1232. end;
  1233.  
  1234. procedure writeskinfile(keyname,filename:string);
  1235. var
  1236.   inifile:TInifile;
  1237.   IniFileName:string;
  1238.   ML:string;
  1239.  
  1240. begin
  1241.   ml:= getapppath+'ini';
  1242.   if Not DirectoryExists(ml) then CreateDir(ml);
  1243.  
  1244.   IniFileName:=GETAPPPath+'ini\Skin.ini';
  1245.   inifile:=TInifile.Create(IniFileName);
  1246.     try
  1247.        inifile.WriteString(keyname,'skinfiles',filename);
  1248.     finally
  1249.       inifile.Free;
  1250.     end;
  1251. end;
  1252.  
  1253. {
  1254. 功能:安全的复制文件
  1255. srcFile,destFile:源文件和目标文件
  1256. bDelDest:如果目标文件已经存在,是否覆盖
  1257. 返回值:true成功,false失败
  1258. }
  1259. function shFileCopy(srcFile,destFile:String;bDelDest:boolean=true):boolean;
  1260. begin
  1261.   result:=false;
  1262.   if not FileExists(srcFile) then
  1263.   begin
  1264.     Application.MessageBox ('源文件不存在,不能复制','提示',MB_OK+MB_ICONEXCLAMATION);
  1265.     exit;
  1266.   end;
  1267.  
  1268.   if srcFile=destFile then
  1269.   begin
  1270.     Application.MessageBox ('源文件和目标文件相同,不能复制','提示',MB_OK+MB_ICONEXCLAMATION);
  1271.     exit;
  1272.   end;
  1273.  
  1274.   if FileExists(destFile) then
  1275.   begin
  1276.   if not bDelDest then
  1277.       begin
  1278.        Application.MessageBox ('目标文件已经存在,不能复制','提示',MB_OK+MB_ICONEXCLAMATION);
  1279.        exit;
  1280.        end
  1281.   else
  1282.   begin
  1283.     if Application.MessageBox('目标文件己存在,要覆盖吗?','提示',MB_OK+MB_ICONQUESTION)=IDOK then
  1284.     begin
  1285.       FileSetAttr(destFile,FileGetAttr(destFile) and not $00000001);
  1286.      
  1287.       if not DeleteFile(PChar(destFile)) then
  1288.       begin
  1289.         Application.MessageBox ('目标文件已经存在,并且不能被删除,复制失败','提示',MB_OK+MB_ICONEXCLAMATION);
  1290.         exit;
  1291.       end;
  1292.     END;
  1293.   END;
  1294.   end; //END IF FILEEXISTS
  1295.      if not CopyFile(PChar(srcFile),PChar(destFile),False ) then     //COPY
  1296.      begin
  1297.        Application.MessageBox ('发生未知的错误,复制文件失败','提示',MB_OK+MB_ICONEXCLAMATION);
  1298.        exit;
  1299.      end;
  1300. //目标文件去掉只读属性
  1301.     FileSetAttr(destFile,FileGetAttr(destFile) and not $00000001);
  1302.     result:=true;
  1303. end;
  1304.  
  1305. procedure loadpicture(str:string;var image:TImage);
  1306. var
  1307.  ms: tmemorystream;
  1308.  mJPeg: TJPegImage;
  1309.  sType:String ;
  1310. begin
  1311.    sType:=ExtractFileExt(str) ;
  1312.    ms:=TMemoryStream.Create ;
  1313.    mJpeg:=TJpegImage.Create ;
  1314.     Try
  1315.      ms.LoadFromFile(str ) ;
  1316.      ms.Position:=0 ;
  1317.     If (UpperCase(sType)='.JPEG') or (UpperCase(sType)='.JPG') Then
  1318.       Begin
  1319.         mJpeg.LoadFromStream(ms) ;    //把JPG流引入
  1320.         Image.Picture.Bitmap.Assign(mJpeg) ;
  1321.      End
  1322.      Else
  1323.       if UpperCase(sType)='.BMP' then
  1324.         Image.Picture.Bitmap.LoadFromStream(ms) ;    //引入BMP流
  1325.    Finally
  1326.    ms.Free ;
  1327.    mJpeg.Free ;
  1328.    End ;
  1329.  
  1330. End ;
  1331.  
  1332. //======================   目录操作
  1333. procedure DelTree(DirName:String);
  1334. var
  1335. hFindFile:Cardinal;
  1336. FileName: String;
  1337. FindFileData:WIN32_FIND_DATA;
  1338. begin
  1339. if DirName[Length(DirName)]<>'\' then
  1340.   DirName:= DirName + '\';
  1341. hFindFile:= FindFirstFile(PChar(DirName + '*.*'), FindFileData);
  1342. if hFindFile <> INVALID_HANDLE_VALUE then
  1343. begin
  1344.   repeat
  1345.    FileName:= FindFileData.cFileName;
  1346.    if (FileName <> '.') and (FileName <> '..') then
  1347.    begin
  1348.     if (FindFileData.dwFileAttributes = FILE_ATTRIBUTE_DIRECTORY) then
  1349.      DelTree(DirName + FileName)
  1350.     else
  1351.      DeleteFile(PChar(DirName + FileName));
  1352.    end;
  1353.   until FindNextFile(hFindFile, FindFileData) = false;
  1354.   Windows.FindClose(hFindFile);
  1355.   RmDir(DirName);
  1356. end;
  1357. end;  
  1358.  
  1359. function EmptyDirectory(TheDirectory :String ; Recursive : Boolean):Boolean;
  1360. var
  1361. SearchRec : TSearchRec;
  1362. Res : Integer;
  1363. begin
  1364. Result := False;
  1365. TheDirectory := Trim(TheDirectory);
  1366. Res := FindFirst(TheDirectory + '*.*', faAnyFile, SearchRec);
  1367. try
  1368. while Res = 0 do
  1369. begin
  1370. if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
  1371. begin
  1372. if ((SearchRec.Attr and faDirectory) > 0) and Recursive
  1373. then begin
  1374. EmptyDirectory(TheDirectory + SearchRec.Name, True);
  1375. RemoveDirectory(PChar(TheDirectory + SearchRec.Name));
  1376. end
  1377. else begin
  1378. DeleteFile(PChar(TheDirectory + SearchRec.Name))
  1379. end;
  1380. end;
  1381. Res := FindNext(SearchRec);
  1382. end;
  1383. Result := True;
  1384. finally
  1385. FindClose(SearchRec);
  1386. //FindClose(SearchRec.FindHandle);
  1387. end;
  1388. end;
  1389.  
  1390. procedure creatdesktoplink(Linkname:string);
  1391. var
  1392.  tmpObject: IUnknown;
  1393.  tmpSLink: IShellLink;
  1394.  tmpPFile: IPersistFile;
  1395.  PIDL: PItemIDList;
  1396.  StartupDirectory: array[0..MAX_PATH] of Char;
  1397.  StartupFilename: string;
  1398.  LinkFilename: WideString;
  1399.  Tempstr:string ;
  1400. begin
  1401.  //StartupFilename := ExtractFilePath(Application.ExeName) + 'xlxt.exe';
  1402.  StartupFilename :=Application.ExeName;
  1403.  
  1404.  if not FileExists(StartupFilename) then Exit;
  1405.  tmpObject := CreateComObject(CLSID_ShellLink);
  1406.  tmpSLink := tmpObject as IShellLink;
  1407.  tmpPFile := tmpObject as IPersistFile;
  1408.  tmpSLink.SetPath(pChar(StartupFilename));
  1409.  tmpSLink.SetWorkingDirectory(pChar(ExtractFilePath(StartupFilename)));
  1410.  SHGetSpecialFolderLocation(0,CSIDL_DESKTOPDIRECTORY,PIDL);
  1411.  SHGetPathFromIDList(PIDL,StartupDirectory);
  1412.  
  1413.  Tempstr :='\'+ Linkname+'.lnk' ;
  1414.  
  1415.  LinkFilename := StartupDirectory + Tempstr ;
  1416.  
  1417.  
  1418.  if FileExists(LinkFileName) then
  1419.  
  1420.   begin
  1421.   application.MessageBox('快捷方式己存在,不能重复建立','提示',MB_OK+  MB_ICONEXCLAMATION);
  1422.   Exit;
  1423.   end
  1424.   else
  1425.   begin
  1426.    tmpPFile.Save(pWChar(LinkFilename), FALSE);
  1427.    application.MessageBox('快捷方式己建立','提示',MB_OK+MB_ICONinformation);
  1428.   END;
  1429. end;
  1430.  
  1431.  
  1432.  
  1433. function setadoaccess(mdbpath:string;passwd:string):string;
  1434. Const
  1435.   SConnectionString       = 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=%s;'
  1436.                                 +'Jet OLEDB:Database Password=%s;';
  1437. begin
  1438.   mdbpath:=trim(mdbpath);
  1439.   passwd:=trim(passwd);
  1440.   result:=format(SConnectionString,[mdbpath,passwd]);
  1441. end;
  1442.  
  1443.  
  1444.  
  1445.  
  1446. end.
  1447.  
downloadUntfun.pas Source code - Download Children's mathematical arithmetic software in Delphi source code Source code
Related Source Codes/Software:
Delphi screen touch cash register system source program - From the perspective of directory structure, this ... 2012-02-18
Delphi examples of using the Image control to display and draw text - The Delphi examples through the use of an Image co... 2012-02-18
Delphi kanji literacy software full version - Delphi pupils ' Chinese character recognition soft... 2012-02-18
Delphi uses the MMS protocol to download streaming media file - Delphi uses the MMS protocol to download streaming... 2012-02-18
Delphi implements a simple P2P chat program - This simple P2P chat software used to simple Serve... 2012-02-18
Image selection/editing plug-in v2.0 Delphi Edition - This is a DELPHI graphics you want to use a plugin... 2012-02-18
Magnificent Delphi implementation interface game Lander - Delphi complete source of legends of the game land... 2012-02-18
Delphi source code enterprise generic invoicing system - A common IT industry enters sells saves management... 2012-02-18
Stamp making software Delphi source code - The DELPHI software is very clever, you can achiev... 2012-02-18
Features of Delphi good teaching management system - A written in DLEPHI language teaching management ... 2012-02-18
Delphi car rental company business management system - A car rental company's business management systems... 2012-02-18
Delphi major revision of the human resources management system source code - RedHR owned a large OFFICE of human resources mana... 2012-02-18
DELPHI pawn industry management system source code - Pawn shop of an integrated business management sys... 2012-02-18
Cool interface Delphi chat software source code - Interface is really cool? This is a small LAN chat... 2012-02-18
Delphi shield Ctrl+Alt+Del reqijian method - Real shielding theory of Delphi is this: using a r... 2012-02-18
Classic RPG games with Delphi source code - The actual and Diablo game or scene is similar in ... 2012-02-18
35 Delphi7 Indy instance package - Application example demonstrates a lot of Indy Dem... 2012-02-18
Delphi transportation company business management system - A Delphi transportation company business managemen... 2012-02-18
Using Delphi to achieve control of the camera - This procedure describes how to use DELPHI AVICAP3... 2012-02-18
Cell of the report component for Delphi example source program - UFIDA table company developed a report component, ... 2012-02-18

 Back to top