热门标签
热门文章
- 1如何在jsp登录页面添加图片验证码(利用action)_jsp网站 图片码
- 2Skywalking使用篇(二)：告警配置_skywalking告警配置
- 312篇顶会论文，深度学习时间序列预测经典方案汇总
- 4英文论文（sci）解读复现【NO.15】学习聚合多尺度背景的实例分割在遥感图像_空间上下文金字塔scp
- 5springboot+mybatis整合，实现增删改查_springboot整合mybatis实现增删改查
- 6Bearpi开发板之HarmonyOS任务管理_鸿蒙线程的等待事件标志时
- 7Android知识体系总结之Android部分之Android系统版本特性篇_android4.4 android9.0特性对比分析
- 82021GPLT天梯赛 L1L2题解_gplt题解
- 9二叉树及其应用_任务描述 本关任务:给出一棵二叉树的括号表示法,本题要求实现3个函数,根据给出的
- 10GPT4.0：探索下一代自然语言处理技术_gpt4.0 csdn
当前位置: article > 正文
delphi写的一个读写xml格式配置文件的帮助类
作者：Gausst松鼠会 | 2024-03-14 12:21:29
赞
踩
xmlconfig delphi
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.
声明：本文内容由网友自发贡献，不代表【wpsshop博客】立场，版权归原作者所有，本站不承担相应法律责任。如您发现有侵权的内容，请联系我们。转载请注明出处：https://www.wpsshop.cn/w/Gausst松鼠会/article/detail/234379
推荐阅读
相关标签
