delphi写的一个读写xml格式配置文件的帮助类

最新推荐文章于 2021-09-09 11:28:16 发布

benwdm

最新推荐文章于 2021-09-09 11:28:16 发布

阅读量342

点赞数

分类专栏： T_L_Delphi 文章标签： XML Delphi Windows

本文链接：https://blog.csdn.net/benwdm/article/details/83723295

版权

T_L_Delphi 专栏收录该内容

18 篇文章 0 订阅

订阅专栏

unit U_SystemParams;

{
==========================================
delphi写的一个读写xml格式配置文件的帮助类
==========================================

写元素和属性的范例代码:
procedure TForm1.Button1Click(Sender: TObject);
var
  sysParams : U_SystemParams;
begin
  sysParams := U_SystemParams.Create();
  try
    sysParams.setElementText('/config/title', '配置文件');
    sysParams.setElementTextAttribute('/config/user', 'name', '张飞');
    sysParams.setElementIntegerAttribute('/config/user', 'age', 22);
    sysParams.setElementBooleanAttribute('/config/user', 'isadmin', true);
    sysParams.setElemenetDatetimeAttribute('/config/user', 'date', Now);
    mmLogs.Lines.Add(sysParams.getXmlDocument.xml);
    sysParams.saveToFile('systemParams.xml');
  finally
    freeandnil(sysParams);
  end;//finally
end;


输出结果如下：
<config>
  <title>配置文件</title>
  <user name="张飞" age="22" isadmin="True" date="2008-8-19"/>
</config>



读元素和属性的范例代码:
procedure TForm1.Button2Click(Sender: TObject);
var
  sysParams : U_SystemParams;
  sTemp : String;
  bTemp : boolean;
  iTemp : Integer;
  dTemp : TDatetime;
begin
  sysParams := U_SystemParams.Create('systemParams.xml');
  try
    sTemp := sysParams.getElementTextAttribute('/config/user', 'name');
    bTemp := sysParams.getElementBooleanAttribute('/config/user', 'isadmin');
    iTemp := sysParams.getElementIntAttribute('/config/user', 'age');
    dTemp := sysParams.getElemenetDateTimeAttribute('/config/user', 'date');
    mmLogs.lines.Add('title = ' + sysParams.getElementText('/config/title'));
    mmLogs.Lines.Add('name = ' + ' = ' + sTemp);
    mmLogs.Lines.Add('isadmin' + ' = ' + BoolToStr(bTemp, true));
    mmLogs.Lines.Add('age' + ' = ' + IntToStr(iTemp));
    mmLogs.Lines.Add('date' + ' = ' + DateTimeToStr(dTemp));
  finally
    freeandnil(sysParams);
  end;//finally
end;


输出结果如下：
title = 配置文件
name = = 张飞
isadmin = True
age = 22
date = 2008-8-19

}

interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, MSXML2_TLB, uUtility;

type
  TSystemParams = class
  private
    FXmlDocument: IXMLDOMDocument;
    FXmlFileName : String;
  protected

  public
    constructor Create(const xmlfilename : String); overload;virtual;
    constructor Create; overload;virtual;
    destructor Destroy; override;
    procedure loadFromFile(const xmlfilename : String); virtual;
    procedure saveToFile; overload;virtual;
    procedure saveToFile(const xmlFileName : String); overload;virtual;
    function getXmlDocument: IXMLDOMDocument; virtual;
    function getElementText(const nodePath: string; const defaultValue : String = ''): string; virtual;
    procedure setElementText(const nodepath, value: string); virtual;

    function getElementTextAttribute(const nodePath, attrName : string; const defaultValue : String = '') : string;
    procedure setElementTextAttribute(const nodePath, attrName, attrValue : string);

    function getElementBooleanAttribute(const nodePath, attrName : String; const default : boolean = false) : boolean;
    procedure setElementBooleanAttribute(const nodePath, attrName : String; const value : boolean);

    function getElementIntAttribute(const nodePath, attrName : String; const default : Integer = -1) : integer;
    procedure setElementIntegerAttribute(const nodePath, attrName : String; const value : integer);

    function getElemenetDateTimeAttribute(const nodePath, attrName : String; const default : TDateTime = 0) : TDateTime;
    procedure setElemenetDatetimeAttribute(const nodePath, attrName : String; const value : TDateTime);

    procedure setElementBoolValue(const nodeName : String; value : boolean);
    function getElementBoolValue(const nodeName : String; const defaultValue : boolean =false) : boolean;

    procedure setElementIntValue(const nodeName : String; value : Integer);
    function getElementIntValue(const nodeName : String; const defaultValue : integer = -1) : Integer;

    procedure setElementDatetimeValue(const nodeName : String; value : TDateTime);
    function getDatetimeValue(const nodeName : String; const defaultValue : TDateTime = 0) : TDateTime;

    function loadXmlElement(const nodePath : string) : IXMLDOMElement; virtual;
  end;
implementation

constructor TSystemParams.Create(const xmlfilename : String);
begin
  FXmlDocument := CoDOMDocument60.Create();
  loadFromFile(xmlfilename);
end;

constructor TSystemParams.Create;
begin
  FXmlDocument := CoDOMDocument60.Create();
end;

destructor TSystemParams.Destroy;
begin
  FXmlDocument := nil;
  inherited;
end;

function TSystemParams.getElementBooleanAttribute(const nodePath, attrName: String; const default: boolean = false): boolean;
begin
  result := StrToBoolDef(getElementTextAttribute(nodePath, attrName, BoolToStr(default, true)), default);
end;

function TSystemParams.getElementBoolValue(const nodeName: String; const defaultValue : boolean =false): boolean;
begin
  Result := StrToBool(getElementText(nodeName, BoolToStr(defaultValue, defaultValue)));
end;

function TSystemParams.getDatetimeValue(const nodeName: String; const defaultValue : TDateTime = 0): TDateTime;
begin
  Result := StrToDateTime(getElementText(nodeName, DateTimeToStr(defaultValue)));
end;

function TSystemParams.getElementIntAttribute(const nodePath, attrName: String; const default: Integer = -1): integer;
begin
  Result := strToInt(getElementTextAttribute(nodePath, attrName, IntToStr(default)));
end;

function TSystemParams.getElementIntValue(const nodeName: String; const defaultValue : integer = -1): Integer;
begin
  Result := StrToInt(getElementText(nodeName, IntToStr(defaultValue)));
end;

function TSystemParams.getElemenetDateTimeAttribute(const nodePath, attrName: String; const default: TDateTime = 0): TDateTime;
begin
  Result := StrToDateTime(getElementTextAttribute(nodePath, attrName, datetoStr(default)));
end;

function TSystemParams.getElementTextAttribute(const nodePath, attrName: string; const defaultValue : String = ''): string;
var
  element : IXMLDOMElement;
  node : IXMLDOMNode;
begin
  element := loadXmlElement(nodePath);
  node := element.attributes.getNamedItem(attrName);
  if node <> nil then
    Result := node.text
  else
    Result := defaultValue;
end;

function TSystemParams.getElementText(const nodePath: string; const defaultValue : String = ''): string;
var
  node: IXMLDOMNode;
  i: Integer;
begin
  result := '';
  node := FXmlDocument.selectSingleNode(nodePath);
  if assigned(node) then
    Result := node.text
  else
    Result := defaultValue;
end;

function TSystemParams.getXmlDocument: IXMLDOMDocument;
begin
  result := FXmlDocument;
end;

function TSystemParams.loadXmlElement(const nodePath: string): IXMLDOMElement;
var
  slist : TStrings;
  i : Integer;
  parent, temp : IXMLDOMElement;
  xName : string;
begin
  result := nil;
  slist := TStringList.Create;
  try
    StrToKenToStrings(nodePath, '/', slist);
    if (sList[0] ='/') or (sList[0] = '') then
    begin
      slist.Delete(0);
    end;
    parent := FXmlDocument.documentElement;
    if (parent <> nil) and (parent.nodeName <> slist[0]) then
      raise Exception.CreateFmt('已经有一个根元素%s了，不能再加一个不同的根%s', [parent.nodeName, slist[0]]);

    for i := 0 to slist.Count - 1 do
    begin
      xName := xName + '/' + slist[i];
      result := IXMLDOMElement(FXmlDocument.selectSingleNode(xName));
      if result = nil then
      begin
        result := FXmlDocument.createElement(slist[i]);
        if i = 0 then
        begin
          parent := Result;
          FXmlDocument.appendChild(parent);
        end
        else
        begin
          parent.appendChild(result);
        end;
        parent := result;
      end;
    end;//i
  finally
    freeandnil(sList);
  end;//finally
end;

procedure TSystemParams.loadFromFile(const xmlfilename : String);
var
  AHasDocument: Boolean;
begin
  FXmlFileName := xmlfilename;
  if FileExists(FXmlFileName) then
    FXmlDocument.load(FXmlFileName)
  else
    raise Exception.Create(FXmlFileName + ' 文件没有找到,加载xml失败');

  FXmlDocument.createProcessingInstruction('xml','version="1.0" encoding="UTF-8"');
end;

procedure TSystemParams.saveToFile();
begin
  FXmlDocument.save(FXmlFileName);
end;

procedure TSystemParams.saveToFile(const xmlFileName: String);
begin
  FXmlDocument.save(xmlFileName);
end;

procedure TSystemParams.setElementBooleanAttribute(const nodePath, attrName: String; const value: boolean);
begin
  setElementTextAttribute(nodePath, attrName, boolToStr(value,  true));
end;

procedure TSystemParams.setElementBoolValue(const nodeName: String; value: boolean);
begin
  setElementText(nodeName, BoolToStr(value, true));
end;

procedure TSystemParams.setElementDatetimeValue(const nodeName: String; value: TDateTime);
begin
  setElementText(nodeName, DateTimeToStr(value));
end;

procedure TSystemParams.setElementIntegerAttribute(const nodePath, attrName: String; const value: integer);
begin
  setElementTextAttribute(nodePath, attrName, IntToStr(value));
end;

procedure TSystemParams.setElementIntValue(const nodeName: String; value: Integer);
begin
  setElementText(nodeName, IntToStr(value));
end;

procedure TSystemParams.setElemenetDatetimeAttribute(const nodePath, attrName: String; const value: TDateTime);
begin
  setElementTextAttribute(nodePath, attrName, DateToStr(value));
end;

procedure TSystemParams.setElementTextAttribute(const nodePath, attrName, attrValue: string);
var
  node : IXMLDOMElement;
  attr : IXMLDOMAttribute;
begin
  node := IXMLDOMElement(FXmlDocument.selectSingleNode(nodePath));
  if node = nil then
    node := loadXmlElement(nodePath);
  attr := FXmlDocument.createAttribute(attrName);
  attr.text := attrValue;
  node.attributes.setNamedItem(attr);
end;

procedure TSystemParams.setElementText(const nodepath, value: string);
var
  node, temp: IXMLDOMNode;
begin
  temp := FXmlDocument.selectSingleNode(nodepath);
  if assigned(temp) then
    temp.text := value
  else
  begin
    temp := loadXmlElement(nodepath);
    temp.text := value;
  end;
end;

end.

其中用到的uUtility单元代码如下：

unit uUtility;

interface

uses
  Forms, Windows, SysUtils, Classes, shellapi, variants, activex, MaskUtils,
  Controls;

resourcestring
  rsCanGetComputerName = '无法取得计算机名';
  rsNotIntegerValue = '"%s" 不是整型数字';
  rsQuestion = '提示';

{-----------------------------------------------------------------------------

  Procedure: StrToken 从源字符串中根据分隔符依次截取并返回分隔符之前的字符串,直到源字符串为空
  Author:    jim(xProcs.pas)
  Date:      2002-7-8
  Arguments: var S: string;
             Seperator: Char;分隔符
  Result:    string  返回分隔符之前的字符
-----------------------------------------------------------------------------}
function StrToken(var S: string; Seperator: Char): string;

{-----------------------------------------------------------------------------
  Procedure: strTokenCount 计算字符串中包含指定字符的个数
  Author:    jim(xProcs.pas)
  Date:      2002-8-30
  Arguments: S: String;       源字符串
             Seperator: Char; 分隔符
             List: TStrings   串表
  Result:    None
-----------------------------------------------------------------------------}
function strTokenCount(S: string; Seperator: Char): Integer;

{-----------------------------------------------------------------------------
  Procedure: strTokenToStrings 把用分隔符隔开的串放入一个串表
  Author:    jim(xProcs.pas)
  Date:      2002-7-8
  Arguments: S: String;       源字符串
             Seperator: Char; 分隔符
             List: TStrings   串表
  Result:    None
-----------------------------------------------------------------------------}
procedure StrToKenToStrings(S: string; Seperator: Char; List: TStrings);

{-----------------------------------------------------------------------------
  Procedure: StrTokenStr 从源字符串中根据分隔字符串依次截取并返回分隔字符串之前的字符串,直到源字符串为空
  Author:    jim
  Date:      2002-7-11
  Arguments: Str: string; 需要截取的字符串
             subStr:string; 分隔字符串
  Result:    Boolean
-----------------------------------------------------------------------------}
function StrTokenStr(var Str: string; const subStr: string): string;

{-----------------------------------------------------------------------------
  Procedure: IsNumeric 判断是否是数字
  Author:    jim
  Date:      2002-7-11
  Arguments: ch: char 字符
  Result:    Boolean
-----------------------------------------------------------------------------}
function IsNumeric(ch: char): boolean;

{-----------------------------------------------------------------------------
  Procedure: IsInteger 检测字符串是否是整数
  Author:    jim
  Date:      2002-7-11
  Arguments: s: string; 待检测字符串
             APositiveOnly:boolean; 只检测正数（默认是 True）
  Result:    Boolean
-----------------------------------------------------------------------------}
function IsInteger(s: string; APositiveOnly: Boolean = True): Boolean;

{-----------------------------------------------------------------------------
  Procedure: IsFloat 检测字符串是否是浮点数
  Author:    jim
  Date:      2002-7-11
  Arguments: s: string; 待检测字符串
             APositiveOnly:boolean; 只检测正数（ 默认是 True）
  Result:    Boolean
-----------------------------------------------------------------------------}
function IsFloat(s: string; APositiveOnly: Boolean = True): Boolean;

{-----------------------------------------------------------------------------
  Procedure: isDateTime 检测字符串是否是日期格式
  Author:    jim
  Date:      2002-8-30
  Arguments: AValue: string 待检测字符串
  Result:    Boolean
-----------------------------------------------------------------------------}
function IsDateTime(const AValue: string): Boolean;

{-----------------------------------------------------------------------------
  Procedure: delay 延时函数，等同于sleep
  Author:    jim(xProcs.pas)
  Date:      2002-7-11
  Arguments: ms: Longint 毫秒
  Result:    None
-----------------------------------------------------------------------------}
procedure delay(ms: Cardinal);

{-----------------------------------------------------------------------------
  Procedure: sysDelay 延时函数
  Author:    jim(xProcs.pas)
  Date:      2002-7-11
  Arguments: aMs: Longint 毫秒
  Result:    None
-----------------------------------------------------------------------------}
procedure sysDelay(aMs: Cardinal);

{-----------------------------------------------------------------------------
  Procedure: ShowInformationMessage 显示一个提示信息话胡框
  Author:    jim
  Date:      2002-10-24
  Arguments: AContent : string; 提示信息
             ATitle : string = 'Information';对话框标题
  Result:    None
-----------------------------------------------------------------------------}
procedure ShowInformationMessage(const AContent: string; const ATitle: string = '提示');

{-----------------------------------------------------------------------------
  Procedure: ShowWarningMessage 显示一个警告信息对话框
  Author:    jim
  Date:      2002-7-16
  Arguments: AContent : string; 警告信息
             ATitle : string = 'Warning';对话框标题
  Result:    None
-----------------------------------------------------------------------------}
procedure ShowWarningMessage(const AContent: string; const ATitle: string = '警告');

{-----------------------------------------------------------------------------
  Procedure: ShowErrorMessage 显示一个错误信息对话框
  Author:    jim
  Date:      2002-7-19
  Arguments: const AContent : string;错误信息
             const ATitle: string = 'Error';对话框标题
  Result:    None
-----------------------------------------------------------------------------}
procedure ShowErrorMessage(const AContent: string; const ATitle: string = '错误');

{-----------------------------------------------------------------------------
  Procedure: ShowInformationMessageFmt 显示一个提示信息对话框
  Author:    jim
  Date:      2002-7-19
  Arguments: const AContent : string;错误信息
             const ATitle: string = 'Error';对话框标题
  Result:    None
-----------------------------------------------------------------------------}
procedure ShowInformationMessageFmt(const AContent: string; Args: array of const; const ATitle: string = '提示');

{-----------------------------------------------------------------------------
  Procedure: ShowErrorMessage 显示一个错误信息对话框
  Author:    jim
  Date:      2002-7-19
  Arguments: const AContent : string;错误信息
             const ATitle: string = 'Error';对话框标题
  Result:    None
-----------------------------------------------------------------------------} procedure ShowWarningMessageFmt(const AContent: string; Args: array of const; const ATitle: string = '警告');
procedure ShowErrorMessageFmt(const AContent: string; Args: array of const; const ATitle: string = '错误');

{-----------------------------------------------------------------------------
  Procedure: Ask 询问是或者否的对话框。返回boolean值
  Author:    jim
  Date:      16-八月-2002
  Arguments: const AContent : string;提示信息
             const Atite : string = 'Question'标题
  Result:    Boolean
-----------------------------------------------------------------------------}
function Ask(const AContent: string; DefaultButton: Byte = 1): Boolean;
{-----------------------------------------------------------------------------
  Procedure: 取得计算机名字
  Author:    jim
  Date:      2004-4-16
  Arguments: None
  Result:    string
-----------------------------------------------------------------------------}
function GetPCName: string;

{-----------------------------------------------------------------------------
  Procedure: BoolToInt 把布尔值转换成整型值,true -> 1; false -> 0
  Author:    jim
  Date:      2002-8-21
  Arguments: const Value : Boolean
  Result:    Integer
-----------------------------------------------------------------------------}
function BoolToInt(const Value: Boolean): Integer;

{-----------------------------------------------------------------------------
  Procedure: IntToBool 把整型值转换成布尔值,1 -> true; 0 -> false
  Author:    jim
  Date:      2002-8-21
  Arguments: const Value : Integer
  Result:    Boolean
-----------------------------------------------------------------------------}
function IntToBool(const Value: Integer): Boolean;

{-----------------------------------------------------------------------------
  Procedure: StringToInt
  Author:    jim
  Date:      2002-8-21
  Arguments: const Value : stirng
  Result:    Boolean
-----------------------------------------------------------------------------}
function StringToInt(const Value: string; DefaultValue: Integer = 0): Integer;

{-----------------------------------------------------------------------------
  Procedure: IntToLenStr 整型转换成定长的字符串
  Author:    jim
  Date:      2002-8-21
  Arguments: i : integer 整型值
        len :integer 返回长度
  Result:    Boolean
-----------------------------------------------------------------------------}
function IntToLenStr(const i, Len: integer): string; overload;
function IntToLenStr(const i, Len: integer; PadChar: char): string; overload;

{-----------------------------------------------------------------------------
  Procedure: IsIncludeChars 指定字符串S中的每一个字符是否存在于CharList字符串中
  Author:    jim
  Date:      2002-8-21
  Arguments: const  S   待判断字符串
             CharList  字符列表串
  Result:    Boolean
-----------------------------------------------------------------------------}
function IsIncludeChars(const S, CharList: string): Boolean;

{-----------------------------------------------------------------------------
  Procedure: AddToVarArray 把指定的开放数组加入到变体数组的最后，使变体数组的Count+1
  Author:    jim
  Date:      2004-4-16
  Arguments: var V: Variant;传出的变体数组 Args: array of const  传入的开放数组
  Result:    None
-----------------------------------------------------------------------------}
procedure AddToVarArray(var V: Variant; Args: array of const);

{-----------------------------------------------------------------------------
  Procedure: ReplaceChar 在字符串中替换字符
  Author:    jim
  Date:      2002-9-5
  Arguments: str :需要替换的字串
             SourceChar:需要替换的字符
             DestChar:替换的字符
  Result:    stirng 返回替换后的字串
-----------------------------------------------------------------------------}
function ReplaceChar(const str: string; SourceChar, DestChar: Char): string;

{-----------------------------------------------------------------------------
  Procedure: addSpaces 在字符串前面或者后面添加指定个数的空格
  Author:    jim
  Date:      2002-9-5
  Arguments: str :需要添加空格的字串
             Len:添加空格的数量
             addAfter:位置（true表示在尾部追加，false表示在首部插入）;
  Result:    stirng 返回处理后的字串
-----------------------------------------------------------------------------}
function addSpaces(Str: string; Len: integer; const addAfter: boolean = true): string;

{-----------------------------------------------------------------------------
  Procedure: 判断键值是否是可显示字符
  Author:    jim
  Date:      2003-08-06
  Arguments: Ch : Word
  Result:    Boolean
-----------------------------------------------------------------------------}
function IsPrintabledChar(Ch: Word): Boolean;

{-----------------------------------------------------------------------------
  Procedure: 得到一个全局唯一的数字，一般用于给控件起名用
  Author:    jim
  Date:      2003-09-24
  Arguments: None
  Result:    Integer
-----------------------------------------------------------------------------}
function GetUniqueNumber: Integer;
{-----------------------------------------------------------------------------
  Procedure: GetAppBarScale
  Author:    jim
  Date:      2003-10-27
  Arguments: None
  Result:    TPoint
-----------------------------------------------------------------------------}
function GetAppBarScale: TPoint;

{-----------------------------------------------------------------------------
  Procedure: URLink 打开指定的url
  Author:    jim
  Date:      2003-10-27
  Arguments: URL: string 网址
  Result:    none
-----------------------------------------------------------------------------}
procedure URLink(URL: string);

{-----------------------------------------------------------------------------
  Procedure: FirstDelimiter 从左侧开始的第一个 Delimiters中任意字符的位置和LastDelimiter作用相反
  Author:    jim
  Date:      2003-12-24
  Arguments: Delimiters ：待选字符
        S： 待查字符
  Result:    Integer
-----------------------------------------------------------------------------}
function FirstDelimiter(const Delimiters, S: string): Integer;

{-----------------------------------------------------------------------------
  Procedure: extractRealFileName 解析得到真正的文件名，返回 文件名.扩展名
  Author:    jim
  Date:      2003-12-24
  Arguments: fileName: string 文件名
  Result:    string 文件名.扩展名
-----------------------------------------------------------------------------}
function extractRealFileName(const fileName: string): string;

{-----------------------------------------------------------------------------
  Procedure: getModuleVersion 得到模块的版本号，模块可以是执行文件也可以是dll和bpl
  Author:    jim
  Date:      2003-12-24
  Arguments: appInstance: Cardinal 模块的实例句柄
  Result:    string 对应模块的版本号
-----------------------------------------------------------------------------}
function getModuleVersion(appInstance: Cardinal): string;

{-----------------------------------------------------------------------------
  Procedure: int2Bin 整型转成二进制字符
  Author:    jim
  Date:      2003-12-24
  Arguments: Value: Cardinal 正整数
  Result:    string 对应二进制数字
-----------------------------------------------------------------------------}
function int2Bin(Value: cardinal): string;
{-----------------------------------------------------------------------------
  Procedure: int2Bin 整型转成二进制字符
  Author:    jim
  Date:      2003-12-24
  Arguments: Value: Cardinal 正整数
  Result:    string 对应二进制数字
-----------------------------------------------------------------------------}
function AddStr(sourcestr: string; Len: Integer; AddStr: Char; Eof: Boolean = False): string;

{-----------------------------------------------------------------------------
  Procedure: generateGUID 计算得到一个GUID
  Author:    jim
  Date:      2003-12-24
  Arguments: none
  Result:    string 全球唯一GUID
-----------------------------------------------------------------------------}
function generateGUID: TGUID;

(*-----------------------------------------------------------------------------
  Procedure: generateGUIDString 生成GUID字符串
  Author:    jim
  Date:      2008-9-16
  Arguments:
  Result:    GUID字符串，类似：{850E7BAC-16BA-40C4-9DD1-E3BFE8FEDC09}
-----------------------------------------------------------------------------*)
function generateGUIDString: string;

{-----------------------------------------------------------------------------
  Procedure: generateGUIDKey 生成GUID主键，32位长度，全字母和数字
  Author:    jim
  Date:      2008-9-16
  Arguments:
  Result:    GUID主键
-----------------------------------------------------------------------------}
function generateGUIDKey: string;

{-----------------------------------------------------------------------------
  Procedure: cloneString 把指定的字符串复制若干次，并返回最终复制后的结果，
  此函数具有缓存机制，可以自动找回上次克隆之后的字符串，提高效率
  Author:    jim
  Date:      2008-9-16
  Arguments: str： 需要克隆的字符串
             cloneCount：克隆的次数
  Result:    克隆后的字符串
-----------------------------------------------------------------------------}
function cloneString(const str: string; const cloneCount: Integer): string;

{-----------------------------------------------------------------------------
  Procedure: var2Int 变体转换成整型
  Author:    jim
  Date:      2008-9-16
  Arguments: v： 需要转换的变体
             def：转换失败的默认值
  Result:    克隆后的字符串
-----------------------------------------------------------------------------}

function var2Int(const v: variant; const def: integer = 0): Integer;

{-----------------------------------------------------------------------------
  Procedure: RemoveEditFormat 在指定格式的字串中提取无格式字串。
             如:格式是">L##!-##!-#;0;" 格式字串"A01-01-1"得到的无格式字串是 A01011。
             要注意的是:abcdefgh 得到的是abcefh
  Author:    jim(Mask.pas)
  Date:      2002-9-5
  Arguments: EditMask :字串的格式，参考 delphi help "TEditMask type"
             Value :格式化字串
             MaskBlank :空白符
  Result:    stirng 返回无格式字串
-----------------------------------------------------------------------------}
function RemoveEditFormat(EditMask: TEditMask; const Value: string; MaskBlank: Char): string;

{-----------------------------------------------------------------------------
  Procedure: nvl 根据对象是否为nil，不为空就返回第二个参数，为空就返回第三个参数
  Author:    jim
  Date:      2008-9-16
  Arguments: prt： 需要检查的指针（可以是对象也可以是接口）;
             val1, val2：需要根据条件返回的值
  Result:    克隆后的字符串
-----------------------------------------------------------------------------}
function nvl(const obj: TObject; const val1, val2: string): string; overload;
function nvl(const obj: TObject; const val1, val2: Integer): Integer; overload;
function nvl(const obj: TObject; const val1, val2: double): double; overload;
function nvl(const obj: TObject; const val1, val2: TObject): TObject; overload;
function nvl(const obj: TObject; const val1, val2: IInterface): IInterface; overload;
function nvl(const obj: TObject; const val1, val2: Char): Char; overload;

function nvl(const intf: IInterface; const val1, val2: string): string; overload;
function nvl(const intf: IInterface; const val1, val2: Integer): Integer; overload;
function nvl(const intf: IInterface; const val1, val2: double): double; overload;
function nvl(const intf: IInterface; const val1, val2: TDatetime): TDateTime; overload;
function nvl(const intf: IInterface; const val1, val2: TObject): TObject; overload;
function nvl(const intf: IInterface; const val1, val2: IInterface): IInterface; overload;
function nvl(const intf: IInterface; const val1, val2: Char): Char; overload;

{-----------------------------------------------------------------------------
  Procedure: ifReturn 根据对象是否为nil，不为空就返回第二个参数，为空就返回第三个参数
  Author:    jim
  Date:      2008-9-16
  Arguments: prt： 需要检查的指针（可以是对象也可以是接口）;
             val1, val2：需要根据条件返回的值
  Result:    返回的字符串
-----------------------------------------------------------------------------}
function ifReturn(const check: boolean; const val1, val2: string): string; overload;
function ifReturn(const check: boolean; const val1, val2: Integer): Integer; overload;
function ifReturn(const check: boolean; const val1, val2: double): double; overload;
function ifReturn(const check: boolean; const val1, val2: TObject): TObject; overload;
function ifReturn(const check: boolean; const val1, val2: IInterface): IInterface; overload;
function ifReturn(const check: boolean; const val1, val2: Char): Char; overload;

{-----------------------------------------------------------------------------
  Procedure: filePath2UrlPath 文件路径转为url路径，例如 c:\aa\bb.ppt 转为 c:/aa/bb.ppt
  Author:    jim
  Date:      2008-9-16
  Arguments: prt： 需要检查的指针（可以是对象也可以是接口）;
             val1, val2：需要根据条件返回的值
  Result:    返回的字符串
-----------------------------------------------------------------------------}
function filePath2UrlPath(const filePath: string): string;

{-----------------------------------------------------------------------------
  Procedure: strRight 从右侧开始，复制指定数量的字符
  Author:    jim
  Date:      2009-1-19
  Arguments: s：原字符串
             count：数量
  Result:    返回的字符串
-----------------------------------------------------------------------------}
function strRight(const s: string; count: Integer): string;

{-----------------------------------------------------------------------------
  Procedure: strHasSuffix 判断字符串(S)是否以指定字符串(subStr)结尾
  Author:    jim
  Date:      2009-1-19
  Arguments: s：原字符串
             subStr：包含的字符串
  Result:    boolean
-----------------------------------------------------------------------------}
function strHasSuffix(const S, subStr: string): boolean;

{-----------------------------------------------------------------------------
  Procedure: parserFtpUrl 解析ftp url，从中得到主机名，用户名，密码，url内容
   例如解析ftp://ftpguest:123@localhost:8022/publicfiles/downloadfields/demo.inf后，得到如下信息
     AHost = localhost
      AUser = ftpguest
      APassword = 123
      AURL = /publicfiles/downloadfields/demo.inf
      APort = 8022
  Author:    jim
  Date:      2009-1-19
  Arguments: AFtpUrl: string; URL地址
             AHost 主机名
             AUser 用户名
             APassword 密码
             AUrl: string URL
             out APort: Integer 端口号
             ADefaultPort: Integer = 21
  Result:    none
-----------------------------------------------------------------------------}
procedure parserFtpUrl(const AFtpUrl: string; out AHost, AUser, APassword, AUrl: string; out APort: Integer; ADefaultPort: Integer = 21);

{-----------------------------------------------------------------------------
  Procedure: setSystemTime 设置系统时间为指定时间
  Author:    jim
  Date:      2009-3-18
  Arguments: const aTime : TTime 时间
  Result:    none
-----------------------------------------------------------------------------}
procedure setSystemTime(const aTime: TTime);

{-----------------------------------------------------------------------------
  Procedure: setSystemDate 设置系统日期为指定日期
  Author:    jim
  Date:      2009-3-18
  Arguments: const aDate : TDate 日期
  Result:    none
-----------------------------------------------------------------------------}
procedure setSystemDate(const aDate: TDate);

{-----------------------------------------------------------------------------
  Procedure: setSystemDateTime 设置系统日期时间为指定日期时间
  Author:    jim
  Date:      2009-3-18
  Arguments: const aDateTime : TDateTime 日期时间
  Result:    none
-----------------------------------------------------------------------------}
procedure setSystemDateTime(const aDateTime: TDateTime);

{-----------------------------------------------------------------------------
  Procedure: readFromFile 读取文本文件内容，返回字符串
  Author:    jim
  Date:      2009-3-18
  Arguments: const fileName : 文本文件全路径名
  Result:    String 返回字符串
-----------------------------------------------------------------------------}
function readFromFile(const fileName: string): string;

{-----------------------------------------------------------------------------
  Procedure: listFiles 显示出目录中的所有文件（不递归子目录）;
  Author:    jim
  Date:      2009-05-11
  Arguments: const path 需要列的目录名
        fileMask : String 文件蒙版，例如*.exe;a*.exe等
  Result:    TStrings
-----------------------------------------------------------------------------}
function listFiles(const path, fileMask: string): TStrings;

{-----------------------------------------------------------------------------
  Procedure: listDirs 显示出目录中的所有目录（不递归子目录）;
  Author:    jim
  Date:      2009-05-11
  Arguments: const path : String
  Result:    TStrings
-----------------------------------------------------------------------------}
function listDirs(const path: string): TStrings;

{-----------------------------------------------------------------------------
  Procedure: deleteDirAndFiles 删除目录以及目录里面的文件
  Author:    jim
  Date:      2009-05-11
  Arguments: const path: string
  Result:    boolean
-----------------------------------------------------------------------------}
function deleteDirAndFiles(const path: string): boolean;

implementation

type
  _TCloneString = record
    count: Integer;
    cloneStr: string;
    result: string;
  end;

var
  _UniqueNumber: Integer;
  _cachedCloneString: _TCloneString;

procedure URLink(URL: string);
begin
  ShellExecute(0, nil, PChar(URL), nil, nil, SW_NORMAL);
end;

function addSpaces(Str: string; Len: integer; const addAfter: boolean = true): string;
var sublen: integer;
  TempStr: string;
begin
  TempStr := str;
  if len > Length(TempStr) then
  begin
    sublen := Len - Length(TempStr);
    if addAfter then
    begin
      TempStr := TempStr + StringofChar(' ', subLen);
    end
    else
    begin
      TempStr := StringofChar(' ', subLen) + TempStr;
    end;
  end
  else
  begin
    TempStr := Copy(TempStr, 1, len);
  end;
  Result := TempStr;
end;

function StrToken(var S: string; Seperator: Char): string;
var
  I: Word;
begin
  I := Pos(Seperator, S);
  if I <> 0 then
  begin
    Result := System.Copy(S, 1, I - 1);
    System.Delete(S, 1, I);
  end
  else
  begin
    Result := S;
    S := '';
  end;
end;

procedure StrToKenToStrings(S: string; Seperator: Char; List: TStrings);
var
  Token: string;
  Flag: Boolean;
begin
  List.Clear;
  Flag := System.Copy(S, length(S), 1) = Seperator;
  while (S <> '') do
  begin
    Token := strToken(S, Seperator);
    List.Add(Token);
  end;
  if Flag then
    List.Add('');
end;

function StrTokenStr(var Str: string; const subStr: string): string;
var
  iPos: Integer;
begin
  iPos := Pos(SubStr, Str);
  SetLength(Result, iPos - 1);
  if iPos <> 0 then
  begin
    Move(Str[1], Result[1], iPos - 1);
    system.Delete(Str, 1, Length(subStr) + iPos - 1);
  end
  else
  begin
    Result := Str;
    Str := '';
  end;
end;

procedure delay(ms: Cardinal);
var
  TickCount: Cardinal;
begin
  TickCount := GetTickCount;
  while GetTickCount - TickCount < ms do
    //Application.ProcessMessages;
    Sleep(ms);
end;

procedure sysDelay(aMs: Cardinal);
begin
  Sleep(aMs);
end;

function IsNumeric(ch: char): boolean;
begin
  Result := ch in ['0'..'9'];
end;

function IsInteger(s: string; APositiveOnly: Boolean = True): Boolean;
var
  i: Integer;
  c: Char;
begin
  Result := False;
  if Length(s) = 0 then
    Exit;
  if APositiveOnly then
  begin
    for i := 1 to Length(s) do
    begin
      c := s[i];
      if not IsNumeric(c) then
        Exit;
    end;
  end
  else
  begin
    for i := 1 to Length(s) do
      if not IsNumeric(s[i]) and ((i <> 1) or (s[i] <> '-')) then
        Exit;
  end;
  Result := True;
end;

function IsFloat(s: string; APositiveOnly: Boolean = True): Boolean;
const
  sDiagits = '.0123456789';
var
  i: Integer;
begin
  Result := False;
  if Length(s) = 0 then
    Exit;
  if APositiveOnly then
  begin
    for i := 1 to Length(s) do
    begin
      if Pos(s[i], sDiagits) <= 0 then
        Exit;
    end;
  end
  else
  begin
    for i := 1 to Length(s) do
    begin
      if Pos(s[i], sDiagits) <= 0 then
        if not ((i = 1) and (s[1] = '-')) then
          Exit;
    end;
  end;
  if (not APositiveOnly) and (s[1] = '-') then
    Result := IsNumeric(s[2])
  else
    Result := IsNumeric(s[1]);
end;

procedure ShowInformationMessage(const AContent: string; const ATitle: string = '提示');
begin
  Application.MessageBox(PChar(AContent), PChar(ATitle)
    , MB_OK + MB_ICONASTERISK + MB_DEFBUTTON1 + MB_APPLMODAL);
end;

procedure ShowWarningMessage(const AContent: string; const ATitle: string = '警告');
begin
  Application.MessageBox(PChar(AContent), PChar(ATitle)
    , MB_OK + MB_ICONEXCLAMATION + MB_DEFBUTTON1 + MB_APPLMODAL);
end;

procedure ShowErrorMessage(const AContent: string; const ATitle: string = '错误');
begin
  Application.MessageBox(PChar(AContent), pchar(ATitle), MB_OK + MB_ICONHAND + MB_DEFBUTTON1 + MB_APPLMODAL);
end;

procedure ShowInformationMessageFmt(const AContent: string; Args: array of const; const ATitle: string = '提示');
begin
  ShowInformationMessage(Format(AContent, args), ATitle);
end;

procedure ShowWarningMessageFmt(const AContent: string; Args: array of const; const ATitle: string = '警告');
begin
  ShowWarningMessage(Format(AContent, args), ATitle);
end;

procedure ShowErrorMessageFmt(const AContent: string; Args: array of const; const ATitle: string = '错误');
begin
  ShowErrorMessage(Format(AContent, args), ATitle);
end;

function Ask(const AContent: string; DefaultButton: Byte = 1): Boolean;
var
  ButtonFlag: Integer;
begin
  case DefaultButton of
    1: ButtonFlag := MB_DEFBUTTON1;
    2: ButtonFlag := MB_DEFBUTTON2;
  else
    ButtonFlag := MB_DEFBUTTON1;
  end;
  Result := Application.MessageBox(PChar(AContent), PChar(rsQuestion), MB_YESNO + MB_ICONQUESTION + ButtonFlag + MB_APPLMODAL) = ID_YES;
end;

function GetPCName: string;
var
  ComputerNameLen: ^DWORD;
  ComputerNameBuffer: PChar;
begin
  Result := '';
  try
    try
      GetMem(ComputerNameBuffer, 255);
      New(ComputerNameLen);
      ComputerNameLen^ := 255;
      if GetComputerName(ComputerNameBuffer, ComputerNameLen^) then
        Result := StrPas(ComputerNameBuffer);
    finally
      FreeMem(ComputerNameBuffer);
      Dispose(ComputerNameLen);
    end;
  except
  end;
end;

function BoolToInt(const Value: Boolean): Integer;
begin
  Result := Ord(Value);
end; { BoolToInt }

function IntToBool(const Value: Integer): Boolean;
begin
  Result := Value <> 0;
end; { IntToBool }

function StringToInt(const Value: string; DefaultValue: Integer = 0): Integer;
begin
  if (Length(Value) = 0) or not IsInteger(Value, False) then
    Result := DefaultValue
  else
    Result := StrToInt(Value);
end;

function IntToLenStr(const i, Len: integer): string;
begin
  result := IntToLenStr(i, Len, ' ');
end;

function IntToLenStr(const i, Len: integer; PadChar: char): string; overload;
begin
  Result := IntToStr(i);
  if Length(Result) <= Len then
    Result := StringOfChar(PadChar, Len - Length(Result)) + Result;
end;

function strTokenCount(S: string; Seperator: Char): Integer;
var
  sTemp: string;
begin
  sTemp := S;
  Result := 0;
  while sTemp <> '' do
  begin { 29.10.96 sb }
    StrToken(sTemp, Seperator);
    Inc(Result);
  end;
end;

function IsIncludeChars(const S, CharList: string): Boolean;
var
  i: Integer;
begin
  Result := False;
  for i := 1 to Length(S) do
  begin
    if Pos(S[i], CharList) <= 0 then
      Exit;
  end; //i
  Result := True;
end;

function IsDateTime(const AValue: string): Boolean;
var
  sDATETIME_CHAR: string;
  sDate, sTime, s, sTemp: string;
  iTemp, iIndex: Integer;
begin
  sDATETIME_CHAR := '1234567890 :' + DateSeparator;
  Result := False;

  //如果长度为零则返回False
  if Trim(AValue) = '' then
    Exit; ;

  //如果包含不可识别字符则返回False
  if not IsIncludeChars(AValue, sDATETIME_CHAR) then
    Exit;
  //如果被日期分隔符隔开的字符串不是3个则返回False
  if strTokenCount(AValue, DateSeparator) <> 3 then
    Exit;
  if strTokenCount(AValue, ' ') > 2 then
    Exit;
  s := AValue;
  sDate := StrToken(s, ' ');
  stime := s;
  iIndex := 0;
  //检测日期
  while sDate <> '' do
  begin
    Inc(iIndex);
    sTemp := StrToken(sDate, DateSeparator);
    if not IsInteger(sTemp) then
      Exit;
    iTemp := StrToInt(sTemp);
    if iTemp = 0 then
      Exit;
    case iIndex of
      2: if iTemp > 12 then
          Exit; //如果月份大于12则返回False
      3: if iTemp > 31 then
          Exit; //如果日期大于31则返回False
    end; //case
  end; //while
  iIndex := 0;
  if sTime <> '' then
  begin
    s := sTime;
    //计算时间部分的被时间分隔符隔开的字符串不是3个则返回False
    if strTokenCount(s, TimeSeparator) <> 3 then
      Exit;
    //检测时间
    while sTime <> '' do
    begin
      Inc(iIndex);
      sTemp := StrToken(sTime, TimeSeparator);
      if not IsInteger(sTemp) then
        Exit;
      iTemp := StrToInt(sTemp);
      case iIndex of
        1: if (iTemp > 24) or (iTemp < 0) then
            Exit; //小时部分检测
        2, 3: if iTemp > 60 then
            Exit; //分钟、秒部分检测
      end; //case
    end; //while
  end; //if
  Result := True; //返回True
end;

procedure AddToVarArray(var V: Variant; Args: array of const);
var
  i, Count: Integer;
  vFields: Variant;
begin
  if not VarIsArray(V) then
    V := VarArrayCreate([0, 0], varVariant);
  Count := VarArrayHighBound(V, 1);
  VarArrayRedim(V, Count + 1);
  vFields := VarArrayCreate([0, High(Args) - Low(Args)], varVariant);
  for i := Low(Args) to High(Args) do
    with Args[i] do
      case VType of
        vtInteger: vFields[i] := Args[i].VInteger;
        vtBoolean: vFields[i] := Args[i].VBoolean;
        vtChar: vFields[i] := Args[i].VChar;
        vtExtended: vFields[i] := Args[i].VExtended^;
        vtString: vFields[i] := Args[i].VString^;
        vtPChar: vFields[i] := string(Args[i].VPChar);
        vtPWideChar: vFields[i] := string(Args[i].VPWideChar);
        vtObject: vFields[i] := Args[i].VObject.ClassName;
        vtClass: vFields[i] := Args[i].VClass.ClassName;
        vtAnsiString: vFields[i] := string(Args[i].VAnsiString);
        vtWideString: vFields[i] := WideString(Args[i].VWideString);
        vtWideChar: vFields[i] := Args[i].VWideChar;
        vtCurrency: vFields[i] := Args[i].VCurrency^;
        vtVariant: vFields[i] := Args[i].VVariant^;
        vtInt64: vFields[i] := Args[i].VInt64^;
        vtInterface: vFields[i] := string(Args[i].VInterface);
      end;
  V[Count] := vFields;
end;

function ReplaceChar(const str: string; SourceChar, DestChar: Char): string;
begin
  Result := str;
  while Pos(SourceChar, Result) > 0 do
    Result[Pos(SourceChar, Result)] := DestChar;
end;

function IsPrintabledChar(Ch: Word): Boolean;
begin
  Result := (Ch > 31) and (Ch < 127);
end;

function GetUniqueNumber: Integer;
begin
  inc(_UniqueNumber);
  Result := _UniqueNumber;
end;

function GetAppBarScale: TPoint;
var
  abd: TAppBarData;
begin
  abd.cbSize := sizeof(abd);
  SHAppBarMessage(ABM_GETTASKBARPOS, abd);
  Result.X := abd.rc.Right - abd.rc.Left;
  Result.Y := abd.rc.Bottom - abd.rc.Top;
end;

function FirstDelimiter(const Delimiters, S: string): Integer;
var
  P: PChar;
begin
  Result := 1;
  P := PChar(Delimiters);
  while Result < Length(S) do
  begin
    if (S[Result] <> #0) and (StrScan(P, S[Result]) <> nil) then
      if (ByteType(S, Result) = mbTrailByte) then
        inc(Result)
      else
        Exit;
    inc(Result);
  end;
end;

function extractRealFileName(const fileName: string): string;
var
  iTemp: Integer;
begin
  Result := fileName;
  iTemp := LastDelimiter('.', Result);
  Delete(Result, iTemp, Length(Result) - iTemp + 1);
end;

function getModuleVersion(appInstance: Cardinal): string;
var
  Size, Size2: DWord;
  Pt, Pt2: Pointer;
begin
  Size := GetFileVersionInfoSize(PChar(GetModuleName(appInstance)), Size2);
  if Size > 0 then
  begin
    GetMem(Pt, Size);
    try
      GetFileVersionInfo(PChar(ParamStr(0)), 0, Size, Pt);
      VerQueryValue(Pt, '\', Pt2, Size2);
      with TVSFixedFileInfo(Pt2^) do
      begin
        Result := IntToStr(HiWord(dwFileVersionMS)) + '.' +
          IntToStr(LoWord(dwFileVersionMS)) + '.' +
          IntToStr(HiWord(dwFileVersionLS)) + '.' +
          IntToStr(LoWord(dwFileVersionLS));
      end; //while
    finally
      FreeMem(Pt);
    end; //finally
  end;
end;

function int2Bin(Value: cardinal): string;
var
  i: Integer;
begin
  SetLength(result, 32);
  for i := 1 to 32 do
  begin
    if ((Value shl (i - 1)) shr 31) = 0 then
      result[i] := '0' {do not localize}
    else
      result[i] := '1'; {do not localize}
  end;
end;

function AddStr(sourcestr: string; Len: Integer; AddStr: Char; Eof: Boolean = False): string;
begin
  while Length(sourcestr) < Len do
  begin
    if Eof then
      sourcestr := sourcestr + AddStr
    else
      sourcestr := AddStr + sourcestr;
  end;
  Result := sourcestr;
end;

function generateGUID: TGUID;
begin
  if CoCreateGuid(Result) = S_OK then
    Exit
  else
    raise exception.Create('GUID 获取失败');
end;

function generateGUIDString: string;
begin
  result := GUIDToString(generateGUID);
end;

function generateGUIDKey: string;
begin
  Result := generateGUIDString;
  delete(Result, 1, 1);
  delete(Result, length(Result), 1);
  Result := StringReplace(Result, '-', '', [rfReplaceAll, rfIgnoreCase]);
end;

function cloneString(const str: string; const cloneCount: Integer): string;
var
  i: Integer;
begin
  if (_cachedCloneString.cloneStr = str) and (_cachedCloneString.count = cloneCount) then
    Result := _cachedCloneString.result
  else
  begin
    _cachedCloneString.result := '';
    _cachedCloneString.count := cloneCount;
    _cachedCloneString.cloneStr := str;
    for i := 0 to cloneCount - 1 do
    begin
      _cachedCloneString.result := _cachedCloneString.result + str;
    end; //i
    Result := _cachedCloneString.result;
  end;
end;

function var2Int(const v: variant; const def: integer = 0): Integer;
begin
  Result := strToIntDef(varToStr(v), def);
end;

function RemoveEditFormat(EditMask: TEditMask; const Value: string; MaskBlank: Char): string;
var
  I: Integer;
  OldLen: Integer;
  Offset, MaskOffset: Integer;
  CType: TMaskCharType;
  Dir: TMaskDirectives;
begin
  Offset := 1;
  Result := Value;
  for MaskOffset := 1 to Length(EditMask) do
  begin
    CType := MaskGetCharType(EditMask, MaskOffset);

    if CType in [mcLiteral, mcIntlLiteral] then
      Result := Copy(Result, 1, Offset - 1) +
        Copy(Result, Offset + 1, Length(Result) - Offset);
    if CType in [mcMask, mcMaskOpt] then Inc(Offset);
  end;

  Dir := MaskGetCurrentDirectives(EditMask, 1);
  if mdReverseDir in Dir then
  begin
    Offset := 1;
    for I := 1 to Length(Result) do
    begin
      if Result[I] = MaskBlank then
        Inc(Offset)
      else
        break;
    end;
    if Offset <> 1 then
      Result := Copy(Result, Offset, Length(Result) - Offset + 1);
  end
  else begin
    OldLen := Length(Result);
    for I := 1 to OldLen do
    begin
      if Result[OldLen - I + 1] = MaskBlank then
        SetLength(Result, Length(Result) - 1)
      else Break;
    end;
  end;
  if MaskBlank <> ' ' then
  begin
    OldLen := Length(Result);
    for I := 1 to OldLen do
    begin
      if Result[I] = MaskBlank then
        Result[I] := ' ';
      if I > OldLen then Break;
    end;
  end;
end;

function nvl(const obj: TObject; const val1, val2: string): string;
begin
  Result := ifReturn(obj <> nil, val1, val2);
end;

function nvl(const obj: TObject; const val1, val2: Integer): Integer;
begin
  Result := ifReturn(obj <> nil, val1, val2);
end;

function nvl(const obj: TObject; const val1, val2: double): double;
begin
  Result := ifReturn(obj <> nil, val1, val2);
end;

function nvl(const obj: TObject; const val1, val2: TObject): TObject;
begin
  Result := ifReturn(obj <> nil, val1, val2);
end;

function nvl(const obj: TObject; const val1, val2: IInterface): IInterface;
begin
  Result := ifReturn(obj <> nil, val1, val2);
end;

function nvl(const obj: TObject; const val1, val2: Char): Char;
begin
  Result := ifReturn(obj <> nil, val1, val2);
end;

function nvl(const intf: IInterface; const val1, val2: string): string;
begin
  Result := ifReturn(intf <> nil, val1, val2);
end;

function nvl(const intf: IInterface; const val1, val2: Integer): Integer;
begin
  Result := ifReturn(intf <> nil, val1, val2);
end;

function nvl(const intf: IInterface; const val1, val2: double): double;
begin
  Result := ifReturn(intf <> nil, val1, val2);
end;

function nvl(const intf: IInterface; const val1, val2: TDatetime): TDateTime;
begin
  Result := ifReturn(intf <> nil, val1, val2);
end;

function nvl(const intf: IInterface; const val1, val2: TObject): TObject;
begin
  Result := ifReturn(intf <> nil, val1, val2);
end;

function nvl(const intf: IInterface; const val1, val2: IInterface): IInterface;
begin
  Result := ifReturn(intf <> nil, val1, val2);
end;

function nvl(const intf: IInterface; const val1, val2: Char): Char;
begin
  Result := ifReturn(intf <> nil, val1, val2);
end;

function ifReturn(const check: boolean; const val1, val2: string): string;
begin
  if check then
    Result := val1
  else
    Result := val2;
end;

function ifReturn(const check: boolean; const val1, val2: Integer): Integer;
begin
  if check then
    Result := val1
  else
    Result := val2;
end;

function ifReturn(const check: boolean; const val1, val2: double): double;
begin
  if check then
    Result := val1
  else
    Result := val2;
end;

function ifReturn(const check: boolean; const val1, val2: TObject): TObject;
begin
  if check then
    Result := val1
  else
    Result := val2;
end;

function ifReturn(const check: boolean; const val1, val2: IInterface): IInterface;
begin
  if check then
    Result := val1
  else
    Result := val2;
end;

function ifReturn(const check: boolean; const val1, val2: Char): Char;
begin
  if check then
    Result := val1
  else
    Result := val2;
end;

function filePath2UrlPath(const filePath: string): string;
begin
  Result := 'file:///' + StringReplace(filePath, '\', '/', [rfReplaceAll, rfIgnoreCase]);
end;

function strRight(const s: string; count: Integer): string;
begin
  Result := Copy(s, Length(s) - count + 1, count);
end;

function strHasSuffix(const S, subStr: string): boolean;
var
  Test: string;
begin
  test := strRight(s, length(subStr));
  Result := SameText(test, subStr);
end;

procedure parserFtpUrl(const AFtpUrl: string; out AHost, AUser, APassword, AUrl: string; out APort: Integer; ADefaultPort: Integer = 21);
const
  C_FTP_HEADER = 'ftp://';
var
  sUrl, sUserStr: string;
  sTemp: string;
begin
  {ftp://ftpguest:123@localhost:8022/publicfiles/downloadfields/demo.inf}
  sUrl := LowerCase(AFtpUrl);
  APort := ADefaultPort;
  StrTokenStr(sUrl, C_FTP_HEADER);

  if pos('@', sUrl) > 0 then
  begin
    sUserStr := strToken(sUrl, '@');
    if sUserStr <> '' then
    begin
      AUser := StrTokenStr(sUserStr, ':');
      APassword := sUserStr;
    end;
  end;

  if Pos(':', sUrl) > 0 then
  begin
    sTemp := strToken(sUrl, ':');
    AHost := sTemp;
    sTemp := strToken(sUrl, '/');
    if sTemp <> '' then
      APort := StrToIntDef(sTemp, ADefaultPort);
  end
  else
    AHost := strToken(sUrl, '/');

  //  AUrl := '/' + sUrl;
  AUrl := sUrl;
end;

procedure setSystemTime(const aTime: TTime);
var
  tmTemp: TSystemTime;
begin
  DateTimeToSystemTime(aTime, tmTemp);
  SetLocalTime(tmTemp);
end;

procedure setSystemDate(const aDate: TDate);
var
  dtTemp: TSystemTime;
begin
  DateTimeToSystemTime(aDate, dtTemp);
  SetLocalTime(dtTemp);
end;

procedure setSystemDateTime(const aDateTime: TDateTime);
var
  dtTemp: TSystemTime;
begin
  DateTimeToSystemTime(aDateTime, dtTemp);
  SetLocalTime(dtTemp);
end;

function readFromFile(const fileName: string): string;
var
  iSize: Integer;
  stream: TFileStream;
begin
  stream := TFileStream.Create(fileName, fmOpenRead or fmShareDenyWrite);
  try
    iSize := stream.Size - stream.Position;
    setString(Result, nil, iSize);
    stream.Read(Pointer(Result)^, iSize);
  finally
    freeandnil(stream);
  end; //finally
end;

function listFiles(const path, fileMask: string): TStrings;
var
  bFound: Integer;
  sr: TSearchRec;
begin
  result := TStringList.Create;
  bFound := FindFirst(path + fileMask, 0, sr);
  try
    while bFound = 0 do
    begin
      result.Add(sr.Name);
      bFound := FindNext(sr);
    end;
  finally
    findClose(sr);
  end; //finally
end;

function listDirs(const path: string): TStrings;
var
  bFound: Integer;
  sr: TSearchRec;
begin
  result := TStringList.Create;
  bFound := FindFirst(path + '\*.*', faDirectory, sr);
  try
    while bFound = 0 do
    begin
      if (sr.Name <> '.') and (sr.Name <> '..') then
        result.Add(sr.Name);
      bFound := FindNext(sr);
    end;
  finally
    findClose(sr);
  end; //finally
end;

function deleteDirAndFiles(const path: string): boolean;
var
  fo: TSHFILEOPSTRUCT;
begin
  FillChar(fo, SizeOf(fo), 0);
  with fo do
  begin
    Wnd := 0;
    wFunc := FO_DELETE;
    pFrom := PChar(path + #0);
    pTo := #0#0;
    fFlags := FOF_NOCONFIRMATION + FOF_SILENT;
  end;//while
  Result := (SHFileOperation(fo) = 0);
end;

initialization
  _UniqueNumber := 0;
  ZeroMemory(@_cachedCloneString, sizeOf(_cachedCloneString));

end.

benwdm

关注

0
点赞
踩
1

收藏

觉得还不错? 一键收藏
0
评论
delphi写的一个读写xml格式配置文件的帮助类

unit U_SystemParams;{==========================================delphi写的一个读写xml格式配置文件的帮助类==========================================写元素和属性的范例代码:procedure TForm1.Button1Click(Sender: TObj...
复制链接

扫一扫