commonprocs.pas

自己整理的 适合新人看 集合有点乱 内容都不错的

unit CommonProcs;

interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, Menus, Registry, DBTables;

//寻找与目标字符串最匹配的字符串
function MaxMatchStr(DestStr:String;Strs:array of String):String;

//删除Text中的空格
function FmtText(Text:String):String;

//格式化浮点数,修正其中的浮点误差
function FmtFloat(Value:Extended;Digits:Integer=4):Double;

//在Str中替换子串
procedure ReplaceStr(var Str:String;const SourceStr,DestStr:String);

//表达式Expression中是否含有项目Item
function IncludeItem(Expression,Item:String):Boolean;

//显示消息框
function MsgBox(const Handle:THandle;Text,Caption:String;
                Flag:Integer):Integer;

//显示消息
procedure ShowMsg(Sender:TCustomForm;Msg:String);

//显示错误,并终止当前事件
procedure ShowError(Sender:TCustomForm;Error:String);

//显示错误
procedure ErrorMsg(Sender:TCustomForm;Error:String);

//显示警告
procedure ShowWarning(Sender:TCustomForm;Warning:String);

//读取注册表数据名称和值
procedure GetNamesAndValues(Registry:TRegistry;NamesValues:TStrings);

//向注册表中写入数据
procedure WriteValues(Registry:TRegistry;ValueNames:array of String;Values:array of Variant);

//读取注册表中的字符串值
function ReadRegistString(ARootKey:HKEY;Key,Name:String;DefaultValue:String=''):String;

//向注册表中写入字符串值
procedure WriteRegistString(ARootKey:HKEY;Key,Name,Value:String);

//读取注册表中的整数值
function ReadRegistInteger(ARootKey:HKEY;Key,Name:String;DefaultValue:Integer=0):Integer;

//向注册表中写入整数值
procedure WriteRegistWord(ARootKey:HKEY;Key,Name:String;Value:Integer);

//读取注册表中的布尔值
function ReadRegistBool(ARootKey:HKEY;Key,Name:String;DefaultValue:Boolean=False):Boolean;

//向注册表中写入布尔值
procedure WriteRegistBool(ARootKey:HKEY;Key,Name:String;Value:Boolean);

//将日期表示为中文格式:XXXX年XX月XX日
function DateToChinese(ADate:TDate):String;

//取本机机器名
function GetComputerName:String;

//取临时文件目录
function GetWinTempDir:String;

//取系统目录
function GetSystemDir:String;

//生成临时文件名
function GetTempFile(PathName,PrefixStr:String;UniqueID:Integer=0):String;

implementation

function MaxMatchStr(DestStr:String;Strs:array of String):String;
var
  I:Integer;
begin
  Result:='';
  for I:=1 to Length(Strs) do
    //如果与目标匹配
    if (Pos(Strs[I],DestStr)>0) and
    //而且比现在找到的结果更长
       (Length(Strs[I])>Length(Result)) then
    //替换当前结果
      Result:=Strs[I];
end;

function FmtText(Text:String):String;
var
  S:String;
begin
  S:=Text;
  while Pos(' ',S)>0 do
    Delete(S,Pos(' ',S),1);
  Result:=S;
end;

//以下代码的目的是修正浮点误差
//方法是在原值基础上增加一个修正量
function FmtFloat(Value:Extended;Digits:Integer=4):Double;
var
  FixValue:Double;
  I:Integer;
begin
  if Value=0 then
    Result:=Value
  else
  begin
    FixValue:=1;
    for I:=1 to Digits+1 do
      FixValue:=FixValue/10;
    if Value>0 then
      Result:=Value+FixValue
    else
      Result:=Value-FixValue
  end;
end;

procedure ReplaceStr(var Str:String;const SourceStr,DestStr:String);
var
  Index:Integer;
begin
  Index:=Pos(SourceStr,Str);
  if Index>0 then
  begin
    Delete(Str,Index,Length(SourceStr));
    Insert(DestStr,Str,Index);
  end;
end;

function IncludeItem(Expression,Item:String):Boolean;
var
  Exp,Itm,S1:String;
  Index,Count:Integer;
begin
  Exp:=UpperCase(Expression);
  Itm:=UpperCase(Item);
  Count:=Length(Itm);
  while Pos(Itm,Exp)>0 do
  begin
    Index:=Pos(Itm,Exp);
    S1:=Copy(Exp,Index+Count,1);   //取后续字符
    if (S1>'9')or(S1<'0') then     //若没有后续字符,或不是数字
    begin
      Result:=True;
      Exit;
    end;
    Delete(Exp,Index,Count);
  end;
  Result:=False;
end;

function MsgBox(const Handle:THandle;Text,Caption:String;
                Flag:Integer):Integer;
begin
  Screen.Cursor:=crDefault;
  Result:=Windows.MessageBox(Handle,
            PChar(Text),PChar(Caption),Flag);
end;

procedure ShowMsg(Sender:TCustomForm;Msg:String);
begin
  MsgBox(Sender.Handle,Msg,Sender.Caption,
         MB_IconInformation or MB_Ok);
end;

procedure ShowError(Sender:TCustomForm;Error:String);
begin
  ErrorMsg(Sender,Error);
  Abort;
end;

procedure ErrorMsg(Sender:TCustomForm;Error:String);
begin
  MsgBox(Sender.Handle,Error,Sender.Caption,
         MB_IconError or MB_Ok);
end;

procedure ShowWarning(Sender:TCustomForm;Warning:String);
begin
  MsgBox(Sender.Handle,Warning,Sender.Caption,
         MB_IconWarning or MB_Ok);
end;

procedure GetNamesAndValues(Registry:TRegistry;NamesValues:TStrings);
var
  I:Integer;
  ValueName,Value:String;
begin
  with Registry,NamesValues do
  begin
    GetValueNames(NamesValues);
    with NamesValues do
    for I:=0 to Count-1 do
    begin
      ValueName:=Strings[I];
      case GetDataType(ValueName) of
        rdString,
        rdExpandString : Value:=ReadString(ValueName);
        rdInteger      : Value:=IntToStr(ReadInteger(ValueName));
      else
        Value:='';
      end;
      Strings[I]:=ValueName+'='+Value;
    end;
  end;
end;

procedure WriteValues(Registry:TRegistry;ValueNames:array of String;Values:array of Variant);
var
  I:Integer;
  ValueName:String;
  Value:Variant;
begin
  if Length(ValueNames)=Length(Values) then
  with Registry do
  for I:=0 to Length(ValueNames)-1 do
  begin
    ValueName:=ValueNames[I];
    Value:=Values[I];
    case VarType(Value) of
      varString : WriteString(ValueName,Value);
      varBoolean: WriteBool(ValueName,Value);
      varByte,
      varSmallInt,
      varInteger: WriteInteger(ValueName,Value);
    end;
  end;
end;

function ReadRegistString(ARootKey:HKEY;Key,Name:String;DefaultValue:String=''):String;
begin
  Result:=DefaultValue;
  with TRegistry.Create do
  try
    RootKey:=ARootKey;
    OpenKey(Key,False);
    try
      Result:=ReadString(Name);
    except
    end;
  finally
    Free;
  end;
end;

procedure WriteRegistString(ARootKey:HKEY;Key,Name,Value:String);
begin
  with TRegistry.Create do
  try
    RootKey:=ARootKey;
    OpenKey(Key,True);
    WriteString(Name,Value);
  finally
    Free;
  end;
end;

function ReadRegistInteger(ARootKey:HKEY;Key,Name:String;DefaultValue:Integer=0):Integer;
begin
  Result:=DefaultValue;
  with TRegistry.Create do
  try
    RootKey:=ARootKey;
    OpenKey(Key,False);
    try
      Result:=ReadInteger(Name);
    except
    end;
  finally
    Free;
  end;
end;

procedure WriteRegistWord(ARootKey:HKEY;Key,Name:String;Value:Integer);
begin
  with TRegistry.Create do
  try
    RootKey:=ARootKey;
    OpenKey(Key,True);
    WriteInteger(Name,Value);
  finally
    Free;
  end;
end;

function ReadRegistBool(ARootKey:HKEY;Key,Name:String;DefaultValue:Boolean=False):Boolean;
begin
  Result:=DefaultValue;
  with TRegistry.Create do
  try
    RootKey:=ARootKey;
    OpenKey(Key,False);
    try
      Result:=ReadBool(Name);
    except
    end;
  finally
    Free;
  end;
end;

procedure WriteRegistBool(ARootKey:HKEY;Key,Name:String;Value:Boolean);
begin
  with TRegistry.Create do
  try
    RootKey:=ARootKey;
    OpenKey(Key,True);
    WriteBool(Name,Value);
  finally
    Free;
  end;
end;

function DateToChinese(ADate:TDate):String;
begin
  Result:=FormatDateTime('yyyy"年"m"月"d"日"',ADate);
end;

function GetComputerName:String;
var
  PComputeName:array[0..MAX_COMPUTERNAME_LENGTH] of Char;
  Length:DWord;
begin
  Length:=SizeOf(PComputeName);
  if Windows.GetComputerName(PComputeName,Length) then
    Result:=StrPas(PComputeName)
  else
    Result:='';
end;

function GetWinTempDir:String;
var
  Path:array[0..Max_Path] of Char;
begin
  Result:='';
  try
    GetTempPath(SizeOf(Path),Path);
    Result:=StrPas(Path);
  except
  end;
end;

function GetSystemDir:String;
var
  Path:array[0..Max_Path] of Char;
begin
  Result:='';
  try
    GetSystemDirectory(Path,SizeOf(Path));
    Result:=StrPas(Path);
  except
  end;
end;

function GetTempFile(PathName,PrefixStr:String;UniqueID:Integer=0):String;
var
  FileName:array[0..2047] of Char;
begin
  //返回值非零，成功
  if GetTempFileName(PChar(PathName),PChar(PrefixStr),
                  UniqueID,@FileName)<>0 then
    Result:=FileName
  else
    Result:='';
end;

end.