untfun.pas

少儿识字软件是根据网络上下载的版本进行了完善

        Result :=1;
        Exit;
      end;

     df :=0;
     
  if pdxz then  //if is 判断\选择题则
    begin
      target:=replacing(target,'.','');  //去除.
      source:=replacing(source,'.','');  //去除.

        // source代表答案,targe代表答的答题
       if Length(target)>Length(source) then
        begin
          Result :=0 ; //多选不得分;
          Exit;
        end;

      str2:=target;
        for i:=1 to Length(source) do
          begin
            str1:=Copy(source,i,1) ;
            if InStr(str1,str2) then
            df:=df+1;  //计算对的个数
          end;

      Result :=df/length(source);
   
     end//如果不是判断/选择题
     else
     begin
       sourcelist :=TStringList.Create ;
       targetlist :=TStringList.Create ;
       TxttoWords(source,sourcelist);
       TxttoWords(target,targetlist);

        if sourcelist.Count >targetlist.Count then
        maxcount :=sourcelist.Count
        else
        maxcount :=targetlist.Count ;//最大值


       str2 :=target ;
       for i:=0 to sourcelist.Count -2 do
         begin
           Temstr:=sourcelist.Strings[i+1];
           str1:=sourcelist.Strings[i]+temstr;
           if InStr(str1,str2) then
              df:=df+1;
         end;

       if df>0 then df:=df+1;
       Result :=df/maxcount;        //输出结果
       // Result :=df/sourcelist.count;
      sourcelist.Free ;  //清除内存
      targetlist.Free ;
     end;

end;



//=========================
function IsForm(FormClass: TFormClass) : boolean; //判断指定窗口存在没有
var
i : integer;
begin
result := False;
for i := 0 to screen.FormCount -1 do
begin
if (screen.Forms[i].ClassType = formClass) then
begin
result := True;
Break;
end;
end;
end;

function isapprun(str:string):boolean; //判断指定程序运行没有
var
HWndCalculator : HWnd;
begin
result:=false;

HWndCalculator := FindWindow(nil, pchar(str));
if HWndCalculator <> 0 then
    result:=true;

end;

function CloseApp(ClassName: String): Boolean;
//关闭外部应用程序
var Exehandle: THandle;
begin
  //ExeHandle := FindWindow(nil, Pchar(Caption));
  ExeHandle := FindWindow(Pchar(ClassName),nil);
  if ExeHandle <> 0
  then
   begin
     PostMessage(ExeHandle, WM_Quit, 0, 0);
     Result:=True;
   end
  else
   begin
     Result:=False;
   end;
end;


{* 获取计算机的IP地址}
function GetHostIP:string;
var
   wVersionRequested : WORD;
   wsaData : TWSAData;
   p : PHostEnt; s : array[0..128] of char; p2 : pchar;
begin
   try
      wVersionRequested := MAKEWORD(1, 1); //创建 WinSock
      WSAStartup(wVersionRequested, wsaData); //创建 WinSock
      GetHostName(@s,128);
      p:=GetHostByName(@s);
      p2 := iNet_ntoa(PInAddr(p^.h_addr_list^)^);
      Result:= P2;
   finally
      WSACleanup; //释放 WinSock
   end;
end;

 {* 获取网络计算机名称}
function GetComputerName:string;
var
   wVersionRequested : WORD;
   wsaData : TWSAData;
   p : PHostEnt; s : array[0..128] of char;
begin
   try
      wVersionRequested := MAKEWORD(1, 1); //创建 WinSock
      WSAStartup(wVersionRequested, wsaData); //创建 WinSock
      GetHostName(@s,128);
      p:=GetHostByName(@s);
      Result:=p^.h_Name;
   finally
      WSACleanup; //释放 WinSock
   end;
end;

//*获取当前Windows登录名的用户
function GetCurrentUserName : string;
const
   cnMaxUserNameLen = 254;
var
   sUserName : string;
   dwUserNameLen : Dword;
begin
   dwUserNameLen := cnMaxUserNameLen-1;
   SetLength( sUserName, cnMaxUserNameLen );
   GetUserName(Pchar( sUserName ), dwUserNameLen );
   SetLength( sUserName, dwUserNameLen );
   Result := sUserName;
end;

//===================================时间处理
function TimeToSecond(const H, M, S: Integer): Integer;
begin
Result := H * 3600 + M * 60 + S;
end;

function TimeSecondToTime(const secs: Integer):string;
var
  H, M, S: Word;
begin
H := secs div 3600;
M := (secs mod 3600) div 60;
S := secs mod 60;

Result :=format('%-.2d', [h])+'：'+format('%-.2d', [m])+ '：'+format('%-.2d', [s]);

end; 


function CONNECTWORD: Boolean;
var
  template:OleVariant ;
  newtemplate:OleVariant ;
  docutype:OleVariant ;
  visible:OleVariant ;

begin
  template:=EmptyParam ;
 // newtemplate :=TRUE;  //模板式
  //docutype:=0;   //模板式
   newtemplate :=False;
   docutype :=wdNewBlankDocument ;    //文档式
   visible :=True;
  try
   begin
    MSWord := CreateOLEObject('Word.Application');//连接Word
    msword.visible:=True;
    msword.Documents.Add(template,newtemplate,docutype ,visible );
    Result:=True;
    END;
  except
    begin
     application.MessageBox('Word文档连接失败','提示',MB_OK+  MB_ICONEXCLAMATION);
     Result :=False ;
     END;
  END;
end;


procedure addstrtoword(text:string;align:Boolean;fontname:WideString;fontsize:integer);
begin
  MSWord.Selection.Font.Size:=fontsize ;
  MSWord.Selection.Font.Name := fontname ;
  if  align then
  MSWord.Selection.ParagraphFormat.Alignment:= wdAlignParagraphCenter
  else
   BEGIN
   MSWord.Selection.ParagraphFormat.Alignment:= wdAlignParagraphLEFT;
   MSWord.Selection.ParagraphFormat.FirstLineIndent:=30;
   end;

  MSWord.Selection.TypeText(text);
  MSWord.Selection.TypeParagraph;
end;

procedure Addbmptoword(str:string );
begin  //str:图片绝对路径;
    msword.Selection.InlineShapes.AddPicture(str,False, True);
end;
{s:加入的字符;FONTNAME:字体名称,FONTSIZE:字体大小;ALIGENM:对齐方式0为左2为中1为右,RICHEDIT为加入对象的载体}

procedure addstrtorich(s, fontname: string; fontsize,alimen: Integer; Richedit: TRichEdit);
begin
  try
    Richedit.Lines.Add(s) ;
    Richedit.SelLength :=-length(s)-2;
    Richedit.SelAttributes.Size :=fontsize ;
    Richedit.SelAttributes.Name :=fontname ;
    Richedit.Paragraph.Alignment :=talignment(alimen) ;
  //  Richedit.SelStart:=Length(Richedit.Lines.Text);
  except
    Exit ;
  END;  
end;

//读取皮肤文件========================================================
function readskinfile(keyname:string):string;
var
 IniFileName:string;
 inifile:TInifile;
 str:string;
 ML:string;
 
begin
  ml:= getapppath+'ini';
  if Not DirectoryExists(ml) then CreateDir(ml);

  IniFileName:=getapppath+'ini\skin.ini';
  inifile:=TInifile.Create(IniFileName);
  str:=inifile.ReadString(Keyname,'skinfiles','');
  inifile.Free;

  Result :=str;

end;

procedure writeskinfile(keyname,filename:string);
var
  inifile:TInifile;
  IniFileName:string;
  ML:string;

begin
  ml:= getapppath+'ini';
  if Not DirectoryExists(ml) then CreateDir(ml);

  IniFileName:=GETAPPPath+'ini\Skin.ini';
  inifile:=TInifile.Create(IniFileName);
    try
       inifile.WriteString(keyname,'skinfiles',filename);
    finally
      inifile.Free;
    end;
end;

{ 
功能：安全的复制文件 
srcFile，destFile：源文件和目标文件 
bDelDest：如果目标文件已经存在，是否覆盖 
返回值：true成功，false失败 
} 
function shFileCopy(srcFile,destFile:String;bDelDest:boolean=true):boolean; 
begin
  result:=false;
  if not FileExists(srcFile) then
  begin
    Application.MessageBox ('源文件不存在，不能复制','提示',MB_OK+MB_ICONEXCLAMATION);
    exit;
  end;

  if srcFile=destFile then
  begin
    Application.MessageBox ('源文件和目标文件相同，不能复制','提示',MB_OK+MB_ICONEXCLAMATION);
    exit;
  end;
  
  if FileExists(destFile) then
  begin
  if not bDelDest then
      begin
       Application.MessageBox ('目标文件已经存在，不能复制','提示',MB_OK+MB_ICONEXCLAMATION);
       exit;
       end
  else
  begin
    if Application.MessageBox('目标文件己存在,要覆盖吗?','提示',MB_OK+MB_ICONQUESTION)=IDOK then
    begin
      FileSetAttr(destFile,FileGetAttr(destFile) and not $00000001);
      
      if not DeleteFile(PChar(destFile)) then
      begin
        Application.MessageBox ('目标文件已经存在，并且不能被删除，复制失败','提示',MB_OK+MB_ICONEXCLAMATION);
        exit;
      end;
    END;
  END;
  end; //END IF FILEEXISTS
     if not CopyFile(PChar(srcFile),PChar(destFile),False ) then     //COPY
     begin
       Application.MessageBox ('发生未知的错误，复制文件失败','提示',MB_OK+MB_ICONEXCLAMATION);
       exit;
     end;
//目标文件去掉只读属性 
    FileSetAttr(destFile,FileGetAttr(destFile) and not $00000001);
    result:=true;
end;

procedure loadpicture(str:string;var image:TImage);
var
 ms: tmemorystream;
 mJPeg: TJPegImage;
 sType:String ;
begin
   sType:=ExtractFileExt(str) ;
   ms:=TMemoryStream.Create ;
   mJpeg:=TJpegImage.Create ;
    Try
     ms.LoadFromFile(str ) ;
     ms.Position:=0 ;
    If (UpperCase(sType)='.JPEG') or (UpperCase(sType)='.JPG') Then
      Begin
        mJpeg.LoadFromStream(ms) ;    //把JPG流引入
        Image.Picture.Bitmap.Assign(mJpeg) ;
     End
     Else
      if UpperCase(sType)='.BMP' then
        Image.Picture.Bitmap.LoadFromStream(ms) ;    //引入BMP流
   Finally
   ms.Free ;
   mJpeg.Free ;
   End ;
 
End ;

//======================   目录操作
procedure DelTree(DirName:String); 
var 
hFindFile:Cardinal; 
FileName: String; 
FindFileData:WIN32_FIND_DATA; 
begin 
if DirName[Length(DirName)]<>'\' then 
  DirName:= DirName + '\'; 
hFindFile:= FindFirstFile(PChar(DirName + '*.*'), FindFileData); 
if hFindFile <> INVALID_HANDLE_VALUE then 
begin 
  repeat 
   FileName:= FindFileData.cFileName; 
   if (FileName <> '.') and (FileName <> '..') then 
   begin 
    if (FindFileData.dwFileAttributes = FILE_ATTRIBUTE_DIRECTORY) then 
     DelTree(DirName + FileName) 
    else 
     DeleteFile(PChar(DirName + FileName)); 
   end; 
  until FindNextFile(hFindFile, FindFileData) = false; 
  Windows.FindClose(hFindFile); 
  RmDir(DirName); 
end; 
end;   

function EmptyDirectory(TheDirectory :String ; Recursive : Boolean):Boolean;
var
SearchRec : TSearchRec; 
Res : Integer; 
begin 
Result := False; 
TheDirectory := Trim(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);
//FindClose(SearchRec.FindHandle);
end;
end;

procedure creatdesktoplink(Linkname:string);
var
 tmpObject: IUnknown;
 tmpSLink: IShellLink;
 tmpPFile: IPersistFile;
 PIDL: PItemIDList;
 StartupDirectory: array[0..MAX_PATH] of Char;
 StartupFilename: string;
 LinkFilename: WideString;
 Tempstr:string ;
begin
 //StartupFilename := ExtractFilePath(Application.ExeName) + 'xlxt.exe';
 StartupFilename :=Application.ExeName;

 if not FileExists(StartupFilename) then Exit;
 tmpObject := CreateComObject(CLSID_ShellLink);
 tmpSLink := tmpObject as IShellLink;
 tmpPFile := tmpObject as IPersistFile;
 tmpSLink.SetPath(pChar(StartupFilename));
 tmpSLink.SetWorkingDirectory(pChar(ExtractFilePath(StartupFilename)));
 SHGetSpecialFolderLocation(0,CSIDL_DESKTOPDIRECTORY,PIDL);
 SHGetPathFromIDList(PIDL,StartupDirectory);

 Tempstr :='\'+ Linkname+'.lnk' ;

 LinkFilename := StartupDirectory + Tempstr ;
 

 if FileExists(LinkFileName) then

  begin
  application.MessageBox('快捷方式己存在,不能重复建立','提示',MB_OK+  MB_ICONEXCLAMATION);
  Exit;
  end
  else
  begin
   tmpPFile.Save(pWChar(LinkFilename), FALSE);
   application.MessageBox('快捷方式己建立','提示',MB_OK+MB_ICONinformation);
  END;
end;



function setadoaccess(mdbpath:string;passwd:string):string;
Const
  SConnectionString       = 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=%s;'
                                +'Jet OLEDB:Database Password=%s;';
begin
  mdbpath:=trim(mdbpath);
  passwd:=trim(passwd);
  result:=format(SConnectionString,[mdbpath,passwd]);
end;




end.