unit utPublic;
(*****公共函数：有关通讯字符串转换，列表操作......****)
interface
uses
SysUtils, Windows, Messages, Classes, Controls,Registry,
StdCtrls, Grids, ExtCtrls, MPlayer, Dialogs,Graphics,
ComCtrls, Buttons,Forms,JPEG,Math,IniFiles,checklst;
type
TCPUID = array[1..4] of DWORD;
TVendor = array [0..11] of char;
const
csfsBold = '|Bold';
csfsItalic = '|Italic';
csfsUnderline = '|Underline';
csfsStrikeout = '|Strikeout';
//========全局函数==============//
function GetCPUIDStr: String;
Function ReadOneParaDefault(sIniFile,Sct,Idt,sDefault:String):String;
procedure StringToFont(sFont: string; Font: TFont; bIncludeColor: Boolean = True);
function FontToString(Font: TFont; bIncludeColor: Boolean = True): string;
Procedure JPG2BMP(sfnBMP,sFnJPG:String);
Procedure BMP2JPG(sfnBMP,sFnJPG:String);
Function MyReadColorDef(aIniFile,Sct,Cnt:String; clDefault:TColor):TColor;
procedure DrawLineH3(x,y,len:Integer;aCanvas:TCanvas;
cl:TColor;direction:Integer);
procedure DrawLineH(x,y,len:Integer;aCanvas:TCanvas;
cl:TColor;direction:Integer);
Function MakeCode(JQM: String; pCode:Byte):String;
Function TimeToSecond(t:TTime):Integer;
Procedure MyCopyFile(sFile,dFile:string);
procedure DeleteOneRegistryValue(_RootKey: HKEY;
_Localkey,sValue: String);
procedure AddOneRegistryValue(_RootKey: HKEY;
_Localkey,sName,sValue: String);
Function RegistryValueExist(_RootKey: HKEY;
_Localkey,sName,sValue: String):Boolean;
procedure MyRectangle(aCanvas:TCanvas;aRect:TRect);
procedure LoadGridTitle(sg: TStringGrid; clb: TCheckListBox);
Function MyReadColor(aIniFile,Sct,Cnt:String):TColor;
procedure MyWriteColor(aIniFile,Sct,Cnt:String;Cl:TColor);
procedure MyReadFont(aIniFile, Sct,Cnt:String; sFont:TFont);
procedure MyWriteFont(aIniFile,Sct,Cnt:String;fFont:TFont);
Function MakeXORString(s:String; cXOR:Byte):String;
Function ReturnXORString(sHex:String):String;
procedure roundRectangle3D(l,t,r,b,dx,dy,nDepth:Integer;aCanvas:TCanvas;
cl,clBack:TColor; bFilled:Boolean);
procedure MyroundRectangle3D(l,t,r,b,dx,dy,nDepth:Integer;aCanvas:TCanvas;
cl:TColor; bDown:Boolean);
procedure ConvertStrToList(mS,LapStr:String; lst:TStrings);
Function ConvertListToSTr(LapStr:String; lst:TStrings):String;
//--------- 微秒延时 ----------------//
procedure MyDelayUs(nUs:Integer);
//--------- 毫秒延时 ----------------//
procedure MyDelayms(nMs:Integer);
Function GetMyID:String;
function GetCPUID : TCPUID; assembler; register;
Function boolStr(bo:Boolean):String;
Function StrToBool(s:String):Boolean;
Procedure MyFmtTextOutH(ss:String; //显示文字
align:Integer; //对齐方式
aCanvas:TCanvas; //画布
aRect:TRect; //显示区域
edge:Byte); //边框宽度
Procedure MyTextOutH(ss:String; //显示文字
align:Integer; //对齐方式
aCanvas:TCanvas; //画布
aRect:TRect; //显示区域
bShowRect:Boolean); //显示矩形边框
Procedure TwoSgCopyOneCol(Var SrcSG:TStringGrid; Col1:integer;
Var DestSG:TStringGrid; Col2:integer);
Procedure AddOneCol(Var SG:TStringGrid);
//------------------得到设备名称列表-----------------//
procedure GetDevTable(sdgParaFile:String;cbType:TComboBox);
Function NormalTime(sTime:String):String;
//-----------把一个表格存盘到INI文件中-------------------//
procedure WriteGridToINI(sFile,Sect:String;sg:TStringGrid);
//-----------从INI文件中读表格数据某行-------------------//
procedure ReadINIToGridRow(sFile,Sect:String;Var sg:TStringGrid; nRow:integer);
//-----------从INI文件中读表格数据某行-------------------//
procedure ReadINIToGridCol(sFile,Sect:String;Var sg:TStringGrid; nCol:integer);
//-----------从INI文件中读表格数据-------------------//
procedure ReadINIToGrid(sFile,Sect:String;Var sg:TStringGrid);
procedure DelOneDevice(devFile:String;sType:String);
Function MonthFile(SubDir,FileNameExt:String):String; //按月读取文件
Function MyStrToFloatDef(s:String; default:Real):Real;
procedure Rectangle3D2(l,t,r,b:Integer;aCanvas:TCanvas;cl,clBack:TColor);
procedure Rectangle3D(l,t,r,b:Integer;aCanvas:TCanvas;cl:TColor);
Function MakeRows(aCanvas:TCanvas; s:String; Var sList:TStringList):Integer;//返回高度和
Procedure MyTextOutV(aCanvas:TCanvas; //画布
x,y:Integer; //位置
sList:TStringList); //显示文字
Procedure WriteStringGrid(Var SG:TStringGrid; fn:String);
Procedure ReadStringGrid(Var SG:TStringGrid; fn:String);
Procedure AddStringGrid(Var SG:TStringGrid; fn:String);
Procedure AddGridToGrid(Var sgS,sgD:TStringGrid);
Procedure EmptyGrid(Var sg:TStringGrid);
Procedure CopyGrid(Var sgS,sgD:TStringGrid);
Procedure CopyGridAbs(Var sgS,sgD:TStringGrid);
Procedure SetGridTitle(Var SG:TStringGrid; sTil:array of String);
Procedure SetGridRowTitle(Var SG:TStringGrid; sTil:array of String);
Procedure SetGridNumber(Var SG:TStringGrid;Col,bn,len:Integer;ch:Char);
Procedure CopyOneRow(Var SG:TStringGrid; RowStart,RowEnd:LongInt);
Procedure SwapTwoCol(Var SG:TStringGrid; ColStart,ColEnd:LongInt);
Procedure SwapTwoRow(Var SG:TStringGrid; RowStart,RowEnd:LongInt);
Procedure ClearOneRowText(Var SG:TStringGrid; Row:LongInt);
Procedure DelOneRow(Var SG:TStringGrid; Row:LongInt);
Procedure AddOneRow(Var SG:TStringGrid);
Procedure InsertOneRow(Var SG:TStringGrid;iRow:Integer);
//把表格中的某行填加到某一文件的最后
Procedure AppendOneRowToFile(Var SG:TStringGrid; Row:LongInt; FileName,AfterHints:String);
//对某列求和
Procedure AppendOneStrToFile(FileName,Txt:String);//填加一行文本在最后
Function SumOneCol(Var SG:TStringGrid; Col:integer):Double;
//对某列求时间总和
Function SumTime(Var SG:TStringGrid; Col:integer; iLo,iHi:LongInt):String;
Procedure SortTable(Var SG:TStringGrid; Col:integer);
Procedure QuickSortTable(Var SG:TStringGrid; Col,iLo,iHi:integer);
Procedure QuickSortTableDown(Var SG:TStringGrid; Col,iLo,iHi:integer);
Procedure SortTableInTwoCol(Var SG:TStringGrid; stdCol,srtCol,iLo,iHi:integer);
Procedure SortTableInThreeCol(Var SG:TStringGrid; stdCol1,stdCol2,srtCol,iLo,iHi:integer);
Procedure TwoSgCopyOneCell(Var SrcSG:TStringGrid; Col1,Row1:integer;
Var DestSG:TStringGrid; Col2,Row2:integer);
Procedure TwoSgCopyOneRow(Var SrcSG:TStringGrid; Row1:integer;
Var DestSG:TStringGrid; Row2:integer);
Function FindString(Var SG:TStringGrid; Col:integer; fs:String):LongInt;
//删除表格中某列所代表的文件
Procedure DelDayFilesOfGrid(Var SG:TStringGrid; Col:integer; Path,Subdir,FileExt:String);
//对表格的某一列tCol进行统计,统计结果放在dSg(共两列）
Procedure TotalSortedGrid(Var sSG,dSg:TStringGrid; nCol:integer);
Procedure SelectSubGrid(Var sSG,dSg:TStringGrid; nCol:integer; keyStr:String);
//按条件筛选表格
Procedure CondSelSubGrid(Var sSG,dSg:TStringGrid; nCol:integer;
keyStr,Oper:String);
Function ReplaceItem(S,LapStr,NewStr:String;nItem,TotalItems:Integer):String;
//替换S的部分字符串SubStr为新字符串NewStr
Function ReplaceString(S,SubStr,NewStr:String):String;
Function DelSubString(s,subStr:String):String;
Function AsciiStr(sNormal:String):String;
//十六进制字符串转换为字节指针（'0A0B'-->$41$42）
Function HexStrToPchar(hs:String; ptr:Pchar):Word;
//读入日期文件名到表格
Procedure ReadDayFile(Var sg:TStringGrid; Path,SubDir,FileNameExt:String);
Procedure ReadDayFile2(Var sg:TStringGrid; Path,SubDir,FileNameExt:String);
//读入日期文件名到表格
Procedure ReadMonthFile(Var sg:TStringGrid; Path,SubDir,FileNameExt:String);
Procedure Mydeletefile(PlayFile:string);
Procedure Delay(len:Longint);
Function GetPlaylen(Fname:String;Mp1:TMediaPlayer):String;
Function Padl(s:string;ch:Char;len:Integer):string;
Function Padc(s:string;ch:Char;len:Integer):string;
Function Padr(s:string;ch:Char;len:Integer):string;
Procedure PadGridL(Var sg:TStringGrid;nCol:integer;ch:Char;len:Integer);
Function GetToday:integer;
Function Leftstr(s:String; len:integer):String;
Function Mytimetostr:string;
Function Timestr:string;
Function Datestr(Lap:Boolean):string;
Function MyDatestr(Adate:TDate;Lap:Boolean):string;
Function Monthstr(Lap:Boolean):string;
Function NextDay(dStr:String; Yesterday:Boolean):String;
Function NextDay2(dStr:String;Yesterday:Boolean):String;
Function NextMonth(dStr:String):String;
//建立以日期为文件名的文件
Function TodayFile(SubDir,FileNameExt:String):String;
Function MakeUniqWavName:String;
Function NtoD(sN:String):String;
Function NtoM(sN:String):String;
Function DtoN(sD:String):String;
Function MtoN(sD:String):String;
//计算两个日期时间之间的小时数之差
Function LapHours(d1,t1,d2,t2:String):double;
Procedure LoadBmpJpg(Var Img:TImage; fn:String);
Procedure LoadBmpJpgOrg(Var Img:TImage; fn:String);
//以下有关字符串操作
(*把'1,2，4,5;6 7'转换为规则字符串'1,2,3,4,5,6,7'*)
Function StrToOrderStr(s,Lapstr:String):String;
(*字符串中的项数，LapStr是分割符字符串*)
Function ItemsOfStr(OrderStr,LapStr:String):Integer;
Function TextOfIndex(OrderStr,LapStr:String;index:Integer):String;
Function SecondToTimeStr(tn:LongInt):String;
Function TimeStrToSecond(ts,Lapstr:String):LongInt;
Function StrToHexStr(Buffer: Pointer; BufferLength: Word):String;
Function BcdToAsc(Buffer:Pointer; BufferLength:Word):String;
Function AscToBcd(sAsc:String; len:Integer):String;
//合法的小时数字符串
Function LegalHour(sHour:String):String;
//合法的小时数字符串
Function LegalMinute(sMinute:String):String;
//合法的整数数字字符串
Function LegalInteger(sInteger:String):String;
//十六进制字符转变为二进制字符串:'F'==>'1111'
Function ChrToBinary(HexCh:Char):String;
Function BinaryStr(HexStr:String):String;
//改变文件扩展名
Function ChangeFileExtName(FileName,NewExtName:String):String;
Function LegalNumber(s:String):String;
procedure ReadColor(Var aIniFile:TIniFile; Sct,Cnt:String;
Var r,g,b:Integer);
procedure WriteColor(Var aIniFile:TIniFile; Sct,Cnt:String;
Cl:TColor);
procedure ReadFont(Var aIniFile:TIniFile;
Sct,Cnt:String;
Var sFont:String;
Var fSize,r,g,b:Integer);
procedure WriteFont(Var aIniFile:TIniFile;
Sct,Cnt:String; fFont:TFont);
Function FontToStr(aFont:TFont):String;
procedure StrToFont(sFont:String;Var fFont:TFont);
Function ColorToStr(aColor:TColor):String;
Function StrToColor(sColor:String):TColor;
Function MyPower(n:integer):LongInt;
Procedure ShowFmtTxt(aCanvas:TCanvas; fmtTxt,YourHint: String);
Procedure ShowFmtTxtRect(aCanvas,backCanvas:TCanvas; fmtTxt,YourHint: String);
Procedure ShowFmtTxtRight(aCanvas,BackCanvas:TCanvas; fmtTxt,YourHint: String);
procedure WriteOnePara(sIniFile,Sct,Idt,Value:String);
Function ReadOnePara(sIniFile,Sct,Idt:String):String;
const
GBPORT=1024;
OKPORT=1034;
VODPORT=1044;
VODPORT2=1045;
dNone=0;
dUp=1; //方向
dRight=2;
dDown=3;
dLeft=4;
EQUATE='=';
UNEQUATE='<>';
GREAT='>';
GREATEQ='>=';
LITLE='<';
LITLEEQ='<=';
CONTAIN='包含';
CURRENTVODFILE='F1'; //播出服务器正在使用的曲库
INSERTPREPLAY='F2'; //DA:'曲目文件;时;分;飞字文本
SORTPREPLAY='F3'; //要求服务器从新排序预约点歌节目单
GETMENUSTATE='F4'; //查询是否正在点歌界面
NEWOKFILE='F5'; //刷新点歌曲库内容
NEWGGFILE='F6'; //刷新广告内容表
NEWFLYFILE='F7'; //刷新飞字广告内容表
NEWMIDIFILE='F8'; //刷新背景音乐内容表
NEWFACEFILE='F9'; //刷新封面广告表
INSERTZM='FA'; //DA:'NO^^TEXT^^WAVE^^DATE
PLAYFLYNOW='FB'; //立即播出飞字通知等
SHOWHINTTV='FC'; //立即播出文字台标
PLAYZMNOW='FD'; //立即发送字幕
NEWTRAINFILE='FE'; //发送时刻表
NEWTELFILE='FF';
TEXTTB='E0'; //接收文字台标
{ if sFunction='E1' then //接收飞字属性
if sFunction='E2' then //接收点歌时间和不按键挂机时间
if sFunction='E3' then //接收空闲提示文本
if sFunction='E4' then //接收广告开关
if sFunction='E5' then //接收空闲广告间隔和是否播出开关
if sFunction='E6' then //接收台名
if sFunction='E7' then //接收自动热线电话号码
if sFunction='E7' then //接收自动热线电话号码
if sFunction='E8' then //接收播放记时牌位置
if sFunction='E9' then //接收飞字播出参数
if sFunction='EA' then //接收点歌背景音乐、语音提示、电话显示开关
if sFunction='EB' then //接收时间显示方式
if sFunction='EC' then //接收点歌选择方式
if sFunction='ED' then //接收字幕留言参数
if sFunction='EE' then //接收图片台标图片参数
if sFunction='EF' then //接收界面文件 }
NEWSHOPFILE='D0';
NEWUserFile='D1';
NEWJMTAB='D2'; //==发送节目预告表==//
NEWTEXTGG='D3'; //==发送文字节目表==//
NEWSGG='D4'; //==发送滚动文字节目表==//
NEWSYGG='D5'; //==发送商业滚动文字节目表==//
NEWInfoFile='D6'; //==发送点播信息库==//
Var
//EVODINI:String; //='Evod75.Wzh';
//MYINIFILE:STring; //='Evod75.jyg'; //不同系统可改变配置文件
cFrq:Int64; //高性能计数器的记数频率
implementation
Function TextOfIndex(OrderStr,LapStr:String;index:Integer):String;
var
i,n,len:integer;
s:String;
begin
Result:=''; //Index>=1
if (index>ItemsOfStr(OrderStr,LapStr))Or (Index<1) then Exit;
n:=1;
s:=OrderStr;
repeat
i:=Pos(LapStr,s);
if i=0 then
begin Result:=s; Exit; end;
if n>=index then
begin Result:=Copy(s,1,i-1); Exit; end;
len:=length(s);
s:=copy(s,i+length(LapStr),len-i-length(LapStr)+1);
n:=n+1;
until False;
end;
Function ItemsOfStr(OrderStr,LapStr:String):Integer;
var
i,len:integer;
s:String;
begin
Result:=1;
if OrderStr='' then Exit;
s:=OrderStr;
repeat
i:=Pos(LapStr,s);
if i=0 then Exit;
Result:=Result+1;
len:=length(s);
s:=copy(s,i+length(LapStr),len-i-length(LapStr)+1);
until False;
end;
Function ReplaceItem(S,LapStr,NewStr:String;nItem,TotalItems:Integer):String;
Var i:Integer;
begin
Result:='';
for i:=1 to TotalItems do
begin
if i<>nItem then Result:=Result+TextofIndex(S,LapStr,i)
else Result:=Result+NewStr;
if i<>TotalItems then Result:=Result+LapStr;
end;
end;
Procedure EmptyGrid(Var sg:TStringGrid);
Var i:Integer;
begin
for i:=1 to sg.RowCount -1 do
sg.Rows[i].clear;
sg.RowCount :=2;
end;
Procedure CopyGrid(Var sgS,sgD:TStringGrid);
Var i:integer;
begin
sgD.RowCount :=sgS.RowCount;
for i:=0 to sgS.RowCount -1 do
TwoSgCopyOneRow(sgS,i,sgD,i);
end;
Procedure CopyGridAbs(Var sgS,sgD:TStringGrid);
Var i:integer;
begin
sgD.RowCount :=sgS.RowCount;
sgD.ColCount :=sgS.ColCount;
for i:=0 to sgS.RowCount -1 do
TwoSgCopyOneRow(sgS,i,sgD,i);
for i:=0 to sgS.ColCount -1 do
sgD.ColWidths[i]:=sgS.ColWidths[i];
end;
Function SecondToTimeStr(tn:LongInt):String;
begin
Result:=Format('%2.2d:%2.2d:%2.2d',[(tn div 3600),
(tn div 60) mod 60,(tn mod 60)]);
end;
Function TimeStrToSecond(ts,Lapstr:String):LongInt;
Var s:String;
begin
Result:=0;
s:=TextOfIndex(ts,LapStr,1);
if Trim(s)<>'' then Result:=Result+3600*strToInt(Trim(s));
s:=TextOfIndex(ts,LapStr,2);
if Trim(s)<>'' then Result:=Result+60*strToInt(Trim(s));
s:=TextOfIndex(ts,LapStr,3);
if Trim(s)<>'' then Result:=Result+strToInt(Trim(s));
end;
Function SumTime(Var SG:TStringGrid; Col:integer; iLo,iHi:LongInt):String;
var i: integer;
tn:LongInt;
begin
tn:=0;
for i:=iLo to iHi do
try
tn:=tn+TimeStrToSecond(sg.Cells[Col,i],':');
except
end;
Result:=SecondToTimeStr(tn);
end;
Function SumOneCol(Var SG:TStringGrid; Col:integer):Double;
var i: integer;
sm:Double;
begin
sm:=0.00;
for i:=1 to Sg.RowCount-1 do
try
sm:=sm+MyStrToFloatDef(sg.Cells[Col,i],0.0);
except
end;
Result:=sm;
end;
//从Grid中选择一个子集
Procedure SelectSubGrid(Var sSG,dSg:TStringGrid; nCol:integer; keyStr:String);
var i: integer;
begin
dsg.RowCount :=1;
dsg.ColCount :=sSg.ColCount;
TwoSgCopyOneRow(sSG,0,dSG,0);
for i:=1 to sSg.RowCount-1 do
if sSg.cells[nCol,i]=keyStr then
begin
dsg.RowCount :=dsg.RowCount +1;
TwoSgCopyOneRow(sSG,i,dSG,dSG.RowCount-1);
end;
end;
Procedure CondSelSubGrid(Var sSG,dSg:TStringGrid; nCol:integer;
keyStr,Oper:String);
var i: integer;
ok:Boolean;
begin
dsg.RowCount :=sSg.FixedRows;
dsg.ColCount :=sSg.ColCount;
for i:=0 to sSg.FixedRows-1 do
TwoSgCopyOneRow(sSG,1,dSG,1);
for i:=1 to sSg.RowCount-1 do
begin
ok:=False;
if (Oper=EQUATE) and (sSg.cells[nCol,i]=keyStr) then
ok:=True
else if (Oper=GREAT) and (sSg.cells[nCol,i]>keyStr) then
ok:=True
else if (Oper=GREATEQ) and (sSg.cells[nCol,i]>=keyStr) then
ok:=True
else if (Oper=LITLE) and (sSg.cells[nCol,i]<keyStr) then
ok:=True
else if (Oper=LITLEEQ) and (sSg.cells[nCol,i]<=keyStr) then
ok:=True
else if Oper=CONTAIN then
begin
if Pos(keyStr,sSg.cells[nCol,i])>0 then ok:=True;
end
else if (Oper=UNEQUATE) and (sSg.cells[nCol,i]<>keyStr) then
ok:=True;
if Ok then
begin
dsg.RowCount :=dsg.RowCount +1;
TwoSgCopyOneRow(sSG,i,dSG,dSG.RowCount-1);
end;
end;
if dsg.RowCount=sSg.FixedRows then
begin
dsg.RowCount:=sSg.FixedRows+1;
dsg.Rows[dsg.RowCount-1].clear;
end;
dsg.FixedRows :=sSg.FixedRows;
end;
Procedure TotalSortedGrid(Var sSG,dSg:TStringGrid; nCol:integer);
Var i,n:Integer;
s:String;
begin
//QuickSortTable(sSG,nCol,1,sSg.RowCount-1);假设已经排序
n:=1;
dSG.RowCount :=2;
s:=sSG.Cells[nCol,1];
dSG.Cells[0,0]:=s;
dSG.cells[1,0]:='1';
dSG.Cells[0,1]:=s; //第一列登记要统计的字符串
dSG.cells[1,1]:='1'; //第二列登记统计的个数
for i:=sSG.FixedRows+1 to sSG.RowCount-1 do
begin
if s=sSG.Cells[nCol,i] then //同一类型数加一
begin
n:=n+1;
if i<sSG.RowCount -1 then Continue
else
begin
dSG.Cells[0,dSG.RowCount-1]:=s; //第一列登记要统计的字符串
dSG.cells[1,dSG.RowCount-1]:=intTostr(n); //第二列登记统计的个数
Exit;
end;
End;
//新类开始
dSG.Cells[0,dSG.RowCount-1]:=s; //第一列登记要统计的字符串
dSG.cells[1,dSG.RowCount-1]:=intTostr(n); //第二列登记统计的个数
dSG.RowCount :=dSG.RowCount+1;
s:=sSG.Cells[nCol,i];
n:=1;
if i=sSG.RowCount -1 then
begin
dSG.Cells[0,dSG.RowCount-1]:=s; //第一列登记要统计的字符串
dSG.cells[1,dSG.RowCount-1]:=intTostr(n); //第二列登记统计的个数
end;
end;
end;
Function StrToOrderStr(s,Lapstr:String):String;
Var st:String;
i,bn:Integer;
begin
st:='';
bn:=0;
for i:=1 to length(s) do
if (s[i]>='0') and (s[i]<='9') then
begin //数字字符
if bn=0 then
begin bn:=i; continue; end; //数字开始处
end
else //非数字字符
begin
if bn=0 then continue;
if st<>'' then st:=st+Lapstr;
st:=st+Copy(s,bn,i-bn);
bn:=0;
end;
if bn>0 then
begin
if st<>'' then st:=st+Lapstr;
st:=st+Copy(s,bn,length(s)+1-bn);
end;
Result:=st;
end;
Function FindString(Var SG:TStringGrid; Col:integer; fs:String):LongInt;
Var i:LongInt;
begin
Result:=0;
for i:=1 to sg.RowCount -1 do
if sg.Cells[col,i]=fs then
begin
Result:=i; Break;
end;
end;
Procedure SetGridTitle(Var SG:TStringGrid; sTil:array of String);
Var i,l,h:integer;
begin
l:=Low(sTil);
h:=High(sTil);
if sg.ColCount<h-l+1 then sg.ColCount:=h-l+1;
for i:=0 to sg.ColCount -1 do
begin
sg.Cells[i,0]:=sTil[l+i];
if i>h then Exit;
end;
end;
Procedure SetGridRowTitle(Var SG:TStringGrid; sTil:array of String);
Var i,l,h:integer;
begin
l:=Low(sTil);
h:=High(sTil);
for i:=0 to sg.RowCount -1 do
begin
sg.Cells[0,i]:=sTil[l+i];
if i>h then Exit;
end;
end;
Procedure SetGridNumber(Var SG:TStringGrid;
Col,bn,len:Integer;ch:Char);
Var i:integer;
begin
for i:=1 to sg.RowCount -1 do
begin
sg.Cells[Col,i]:=Format('%d',[bn+i-1]);
sg.Cells[Col,i]:=Padl(sg.Cells[Col,i],ch,len);
end;
end;
Procedure SwapTwoRow(Var SG:TStringGrid; RowStart,RowEnd:LongInt);
Var i:Integer;
s:String;
begin
for i:=0 to sg.ColCount -1 do
begin
s:=sg.cells[i,RowStart];
sg.cells[i,RowStart]:=sg.cells[i,RowEnd];
sg.cells[i,RowEnd]:=s;
end;
end;
Procedure SwapTwoCol(Var SG:TStringGrid; ColStart,ColEnd:LongInt);
Var i:Integer;
s:String;
begin
for i:=0 to sg.RowCount -1 do
begin
s:=sg.cells[ColStart,i];
sg.cells[ColStart,i]:=sg.cells[ColEnd,i];
sg.cells[ColEnd,i]:=s;
end;
end;
Procedure TwoSgCopyOneCell(Var SrcSG:TStringGrid; Col1,Row1:integer;
Var DestSG:TStringGrid; Col2,Row2:integer);
begin
DestSG.Cells[col2,row2]:=SrcSG.Cells[col1,row1];
end;
Procedure TwoSgCopyOneRow(Var SrcSG:TStringGrid; Row1:integer;
Var DestSG:TStringGrid; Row2:integer);
Var i:integer;
begin
for i:=0 to SrcSG.ColCount -1 do
TwoSgCopyOneCell(SrcSG,i,Row1,DestSG,i,Row2);
end;
Procedure SortTable(Var SG:TStringGrid; Col:integer);
Var i,j,k:Integer;
s:String;
begin
for i:=1 to SG.RowCount-2 do
for k:=i+1 to SG.RowCount-1 do
if SG.Cells[col,i]< SG.Cells[col,k] then
for j:=0 to sg.ColCount -1 do
begin
s:=SG.Cells[j,i];
SG.Cells[j,i]:=SG.Cells[j,k];
SG.Cells[j,k]:=s;
end;
end;
Procedure SortTableInTwoCol(Var SG:TStringGrid; stdCol,srtCol,iLo,iHi:integer);
Var i,b,e:integer;
s:String;
begin
//QuickSortTable(sg,stdCol,iLo,iHi);已对stdCol排序
b:=iLo;
s:=sg.Cells[stdCol,iLo];
for i:=iLo+1 to iHi do
begin
if s=sg.Cells[stdCol,i] then continue;
e:=i-1;
QuickSortTable(sg,srtCol,b,e);
b:=i;
s:=sg.Cells[stdCol,b];
end;
if sg.Cells[stdCol,iHi]=s then
QuickSortTable(sg,srtCol,b,iHi);
end;
Procedure SortTableInThreeCol(Var SG:TStringGrid; stdCol1,stdCol2,srtCol,iLo,iHi:integer);
Var i,b,e:integer;
s1,s2:String;
begin
//QuickSortTable(sg,stdCol1,iLo,iHi);已对stdCol1排序
//SortTableInTwoCol(sg,stdCol1,stdCol2,iLo,iHi);已对stdCol2排序
b:=iLo;
s1:=sg.Cells[stdCol1,iLo];
s2:=sg.Cells[stdCol2,iLo];
for i:=iLo+1 to iHi do
begin
if (s1=sg.Cells[stdCol1,i]) and
(s2=sg.Cells[stdCol2,i]) then continue;
e:=i-1;
QuickSortTable(sg,srtCol,b,e);
b:=i;
s1:=sg.Cells[stdCol1,b];
s2:=sg.Cells[stdCol2,b];
end;
if (s1=sg.Cells[stdCol1,iHi]) and
(s2=sg.Cells[stdCol2,iHi]) then
QuickSortTable(sg,srtCol,b,iHi);
end;
Procedure AddOneRow(Var SG:TStringGrid);
begin
if sg.Cells[0,1]='' then //Second Line is empty
begin
sg.RowCount:=2;
sg.Row:=1;
end
else
begin
sg.RowCount :=sg.RowCount+1;
sg.Row:=sg.RowCount-1;
sg.Rows[sg.row].clear;
end;
end;
Procedure InsertOneRow(Var SG:TStringGrid;iRow:Integer);
Var i,cur:integer;
begin
cur:=iRow; //SG.row;
//if SG.Cells[0,cur]='' then Exit;
sg.RowCount :=sg.RowCount+1;
for i:=SG.RowCount-2 downto cur do
CopyOneRow(SG,i,i+1);
sG.Rows[Cur].clear;
SG.Row:=Cur;
end;
Procedure CopyOneRow(Var SG:TStringGrid; RowStart,RowEnd:LongInt);
var i:integer;
begin
for i:=0 to SG.ColCount-1 do
sg.Cells[i,RowEnd]:=sg.cells[i,RowStart];
end;
procedure StrGridToStr(Var S:String; Var SG:TStringGrid; Row:longint);
Var i:integer;
begin
S:='';
for i:=0 to SG.ColCount -1 do
S:=S+SG.Cells[i,Row]+'^^';
end;
procedure WriteStringGrid(Var SG:TStringGrid; fn:String);
var f:Text;
i:integer;
s:String;
begin
{$I-}
Assignfile(f,fn);
Rewrite(f);
try
for i:=1 to SG.RowCount-1 do
begin
StrgridToStr(S,SG,i);
Writeln(f, S);
end;
finally
Closefile(f);
end;
end;
procedure StrToStrgrid(Var S:String;Var sg:TStringGrid; row:longint);
var
i,j,len:integer;
begin
sg.Rows[row].Clear;
for j:=0 to sg.ColCount-1 do
begin
i:=Pos('^^',S);
if i=0 then
begin
sg.Cells[j,row]:=s;
exit;
end;
len:=length(s);
sg.Cells[j,row]:=copy(s,1,i-1);
s:=copy(s,i+2,len-i-1);
end;
end;
Function GetcolCount(St:String):Integer;
var
i,len:integer;
s:String;
begin
Result:=0;
s:=st;
repeat
i:=Pos('^^',S);
if i=0 then Exit;
result:=result+1;
len:=length(s);
s:=copy(s,i+2,len-i-1);
until False;
end;
Procedure ClearOneRowText(Var SG:TStringGrid; Row:LongInt);
Var i:integer;
begin
for i:=0 to sg.ColCount -1 do
sg.cells[i,Row]:='';
end;
Procedure DelOneRow(Var Sg:TStringGrid; Row:LongInt);
Var i,j:longInt;
begin
if sg.RowCount<3 then
begin
sg.Rows[1].clear; // ClearOneRowText(sg,Row);
Exit;
end;
if Row=sg.RowCount-1 then
begin
sg.Row:=sg.RowCount-2;
sg.Rows[row].clear;
sg.RowCount:=sg.RowCount-1;
Exit;
end;
for i:=Row to sg.RowCount -2 do
for j:=0 to sg.ColCount -1 do
sg.cells[j,i]:=sg.cells[j,i+1];
sg.Rows[sg.Rowcount-1].clear;
sg.RowCount:=sg.RowCount-1;
end;
Procedure ReadStringGrid(Var SG:TStringGrid; fn:String);
var f:textfile;
Total:LongInt;
s:String;
begin
{$I-}
SG.RowCount :=2;
if Not FileExists(fn) then
begin
SG.Rows[1].clear;
Exit;
end;
AssignFile(f,fn);
Reset(f);
Total:=1;
try
while not(EOF(f)) do
begin
Readln(f, S);
if Total=1 then
if SG.ColCount<GetcolCount(S) then
SG.ColCount :=GetcolCount(S);
Total:=Total+1;
SG.RowCount :=Total;
StrToStrgrid(S,SG,Total-1);
end;
finally
Closefile(f);
end;
end;
//往已有的表格填加文件中的数据
Procedure AddStringGrid(Var SG:TStringGrid; fn:String);
var f:textfile;
s:String;
begin
if Not FileExists(fn) then Exit;
if (sg.RowCount=2) and (sg.Cells[0,1]='') then
begin ReadStringGrid(SG,fn); Exit; end;
AssignFile(f,fn);
Reset(f);
try
while not(EOF(f)) do
begin
Readln(f, S);
SG.RowCount :=SG.RowCount+1;
StrToStrgrid(S,SG,SG.RowCount-1);
end;
finally
Closefile(f);
end;
end;
//把一个表格填加到另一个表格后
Procedure AddGridToGrid(Var sgS,sgD:TStringGrid);
Var i:integer;
begin
if sgS.Cells[0,sgS.FixedRows]='' then Exit;
for i:=sgS.FixedRows to sgS.RowCount -1 do
begin
if (sgd.RowCount=2) and (sgd.Cells[0,1]='') then
sgD.RowCount :=2
else sgD.RowCount :=sgD.RowCount +1;
TwoSgCopyOneRow(sgS,i,sgD,sgD.RowCount-1);
end;
end;
procedure Delay(len:Longint);
var
i,j:Longint;
begin
j:=1;
for i:=0 to len do j:=j*i-j*i;
end;
Function GetToday:integer;
var
Present: TDateTime;
Year, Month, Day : Word;
begin
Present:= Now;
DecodeDate(Present, Year, Month, Day);
Result:=year*10000+month*100+day;
end;
Function Leftstr(s:String; len:integer):String;
begin
if len<0 then
begin
result:='';
exit;
end;
if len>=length(s) then
begin
result:=s;
exit;
end;
result:=Copy(s,1,len);
end;
Procedure PadGridL(Var sg:TStringGrid;nCol:integer;ch:Char;len:Integer);
Var i:integer;
begin
for i:=sg.FixedRows to sg.RowCount -1 do
sg.Cells[ncol,i]:=PadL(sg.cells[ncol,i],ch,len);
end;
Function Padl(s:string;ch:Char;len:Integer):string;
var
i,l:integer;
tmpstr:String;
begin
l:=Length(s);
tmpstr:=s;
if len<0 then
begin
result:='';
exit;
end;
if l<len then
for i:=1 to len-l do
tmpstr:=ch+tmpstr;
result:=tmpstr;
end;
Function Padr(s:string;ch:Char;len:Integer):string;
var
i,l:integer;
tmpstr:String;
begin
l:=Length(s);
tmpstr:=s;
if len<0 then
begin
Result:='';
Exit;
end;
if l<len then
for i:=1 to len-l do
tmpstr:=tmpstr+ch;
result:=tmpstr;
end;
Function Padc(s:string;ch:Char;len:Integer):string;
var
i,l:integer;
tmpstr:String;
begin
l:=Length(s);
tmpstr:=s;
if len<0 then
begin
Result:='';
Exit;
end;
if l<len then
begin
for i:=1 to ((len-l) div 2) do
tmpstr:=ch+tmpstr;
for i:=1 to ( len-l-((len-l) div 2)) do
tmpstr:=tmpstr+ch;
end;
Result:=tmpstr;
end;
Function Timestr:string;
var
Present: TDateTime;
Hour, Min, Sec, MSec: Word;
begin
Present:= Now;
DecodeTime(Present, Hour, Min, Sec, MSec);
Result:=Format('%2.2d%2.2d%2.2d',[Hour, Min, Sec]);
end;
Function Mytimetostr:string;
var
Present: TDateTime;
Hour, Min, Sec, MSec: Word;
begin
Present:= Now;
DecodeTime(Present, Hour, Min, Sec, MSec);
Result:=Format('%2.2d:%2.2d:%2.2d',[Hour, Min, Sec])
end;
Function Datestr(Lap:Boolean):string;
var
Present: TDateTime;
Year, Month, Day : Word;
begin
Present:= Now;
DecodeDate(Present, Year, Month, Day);
if Lap then
result:=Format('%4.4d-%2.2d-%2.2d',[year,month,Day])
else
result:=Format('%4.4d%2.2d%2.2d',[year,month,Day])
end;
Function Monthstr(Lap:Boolean):string;
var
Present: TDateTime;
Year, Month, Day : Word;
begin
Present:= Now;
DecodeDate(Present, Year, Month, Day);
if Lap then
result:=Format('%4.4d-%2.2d',[year,month])
else
result:=Format('%4.4d%2.2d%',[year,month])
end;
Function MyDatestr(Adate:TDate;Lap:Boolean):string;
var
Year, Month, Day : Word;
begin
DecodeDate(Adate, Year, Month, Day);
if Lap then
result:=Format('%4.4d-%2.2d-%2.2d',[year,month,Day])
else
result:=Format('%4.4d%2.2d%2.2d',[year,month,Day])
end;
Procedure Mydeletefile(PlayFile:string);
var
fs:array[0..80] of char;
begin
if not FileExists(PlayFile) then Exit;
strPcopy(fs,Playfile);
FileSetAttr(PlayFile,0);
DeleteFile(fs);
end;
Function GetPlaylen(Fname:String;Mp1:TMediaPlayer):String;
var s:string;
len:longint;
begin
s:=ExtractFileExt(Fname);
s:=uppercase(s);
if (s='.BMP') OR (s='.JPG') OR (s='.ICO') then
begin
Result:='00:00:05'; Exit;
end;
Mp1.FileName:=Fname;
Mp1.Devicetype:=dtAutoSelect;
s:='Yes';
try
Mp1.close;
Mp1.Open;
except
s:='Error';
ShowMessage('不能识别媒体文件:'+Fname);
end; { if MP1.Error<>0 then}
if s='Error' then
begin
result:='';
exit;
end;
MP1.TimeFormat:=tfMilliseconds;
len:=MP1.length;
case MP1.TimeFormat of
tfMilliseconds: len:=len div 1000;
tfMSF: len:=len*60;
tfFrames: len:=len div 25;
tfSMPTE24: len:=len div 24;
tfSMPTE25: len:=len div 25;
tfSMPTE30: len:=len div 30;
tfSMPTE30Drop: len:=len div 30;
else
begin
{ tfHMS: len:=w1*3600+w2*60+w3;
tfBytes:
tfSamples:
tfTMSF: }
s:=IntTostr(MP1.length);
result:=Padl(s,'0',7);
exit;
end;
end;
s:=Format('%2.2d:%2.2d:%2.2d',[len div 3600,(len div 60) mod 60,len Mod 60]);
result:=s;
end;
Procedure QuickSortTable(Var SG:TStringGrid; Col,iLo,iHi:integer);
var
Lo, Hi: Integer;
Mid:String;
begin
//if sg.RowCount <100 then begin SortTable(SG,Col); Exit; end;
Lo := iLo;
Hi := iHi;
if Hi=Lo+1 then
if sg.Cells[col,Lo]>sg.Cells[col,Hi] then
begin
SwapTwoRow(sg,Lo,Hi);
Exit;
end;
Mid :=sg.cells[col,(Lo + Hi) div 2];
repeat
while sg.Cells[col,Lo] < Mid do Inc(Lo);
while sg.Cells[col,Hi] > Mid do Dec(Hi);
if Lo <= Hi then
begin
SwapTwoRow(sg,Lo,Hi);
Inc(Lo);
Dec(Hi);
end;
until Lo > Hi;
if Hi > iLo then QuickSortTable(sg,Col,iLo,Hi);
if Lo < iHi then QuickSortTable(sg,Col,Lo,iHi);
end;
//按降序排序
Procedure QuickSortTableDown(Var SG:TStringGrid; Col,iLo,iHi:integer);
var
Lo, Hi: Integer;
Mid:String;
begin
Lo := iLo;
Hi := iHi;
if Hi=Lo+1 then
if sg.Cells[col,Lo]<sg.Cells[col,Hi] then
begin
SwapTwoRow(sg,Lo,Hi);
Exit;
end;
Mid :=sg.cells[col,(Lo + Hi) div 2];
repeat
while sg.Cells[col,Lo] > Mid do Inc(Lo);
while sg.Cells[col,Hi] < Mid do Dec(Hi);
if Lo <= Hi then
begin
SwapTwoRow(sg,Lo,Hi);
Inc(Lo);
Dec(Hi);
end;
until Lo > Hi;
if Hi > iLo then QuickSortTableDown(sg,Col,iLo,Hi);
if Lo < iHi then QuickSortTableDown(sg,Col,Lo,iHi);
end;
Function TodayFile(SubDir,FileNameExt:String):String;
Var path:String;
begin
{$I-}
path:=ExtractFilePath(application.ExeName);//路径
if not FileExists(path+SubDir) then mkdir(path+SubDir);
Result:=path+SubDir+'\'+Datestr(False)+'.'+FileNameExt;
end;
Function MonthFile(SubDir,FileNameExt:String):String; //按月读取文件
Var path:String;
begin
{$I-}
path:=ExtractFilePath(application.ExeName);//路径
if not FileExists(path+SubDir) then mkdir(path+SubDir);
Result:=path+SubDir+'\'+Monthstr(False)+'.'+FileNameExt;
end;
Function MakeUniqWavName:String;
Var path,dir,fn:String;
begin
{$I-}
path:=ExtractFilePath(application.ExeName);//路径
dir:='W'+copy(Datestr(False),1,6); //'w'+年月作为子目录
if not FileExists(path+dir) then mkdir(path+dir);
fn:=copy(Datestr(False),7,2)+TimeStr+'.wav';//日时分秒作为文件名
Result:=path+dir+'\'+fn;
end;
Function NtoD(sN:String):String;
begin
Result:=Copy(sN,1,4)+'年'+copy(sN,5,2)+'月'+copy(sN,7,2)+'日';
end;
Function NtoM(sN:String):String;
begin
Result:=Copy(sN,1,4)+'年'+copy(sN,5,2)+'月';
end;
Function DtoN(sD:String):String;
begin
Result:=Copy(sD,1,4)+copy(sD,7,2)+copy(sD,11,2);
end;
Function MtoN(sD:String):String;
begin
Result:=Copy(sD,1,4)+copy(sD,7,2);
end;
Procedure LoadBmpJpgOrg(Var Img:TImage; fn:String);
Var JpegImage:TJpegImage;
tmpMap:TImage;
begin
if FileExists(fn) then
begin
img.Picture.Assign(nil);
if Uppercase(ExtractFileExt(fn))='.JPG' then
begin
JpegImage:=TJpegImage.Create;
tmpMap:=TImage.Create(nil);
try
JpegImage.LoadFromFile(fn);
tmpMap.Width :=JpegImage.Width;
tmpMap.Height :=JpegImage.Height;
tmpMap.Picture.Graphic:=JpegImage;
img.Canvas.Draw(0,0,tmpMap.Picture.Graphic);
finally
tmpMap.free;
JpegImage.Free;
end;
end
else
img.Picture.LoadFromFile(fn);
end
else
img.Picture.Assign(nil);
end;
Procedure LoadBmpJpg(Var Img:TImage; fn:String);
Var JpegImage:TJpegImage;
tmpMap:TImage;
begin
if FileExists(fn) then
begin
img.Picture.Assign(nil);
if Uppercase(ExtractFileExt(fn))='.JPG' then
begin
JpegImage:=TJpegImage.Create;
tmpMap:=TImage.Create(nil);
try
JpegImage.LoadFromFile(fn);
//JpegImage.CompressionQuality:=100;
tmpMap.Picture.Graphic:=JpegImage;
img.Canvas.StretchDraw(Rect(0,0,img.width,img.height),tmpMap.Picture.Graphic);
//img.Canvas.StretchDraw(Rect(0,0,img.width,img.height),JpegImage);
finally
tmpMap.free;
JpegImage.Free;
end;
end
else
begin
tmpMap:=TImage.Create(nil);
try
tmpMap.Picture.LoadFromFile(fn);
img.Canvas.StretchDraw(Rect(0,0,img.width,img.height),tmpMap.Picture.Graphic);
finally
tmpMap.free;
end;
end;
end
else
img.Picture.Assign(nil);
end;
Procedure JPG2BMP(sfnBMP,sFnJPG:String);
Var JpegImage:TJpegImage;
tmpMap:TImage;
begin
JpegImage:=TJpegImage.Create;
tmpMap:=TImage.Create(nil);
try
JpegImage.LoadFromFile(sFnJPG);
tmpMap.Picture.Graphic:=JpegImage;
tmpMap.Picture.SaveToFile(sFnBMP);
finally
tmpMap.free;
JpegImage.Free;
end;
end;
Procedure BMP2JPG(sfnBMP,sFnJPG:String);
Var JpegImage:TJpegImage;
tmpMap:TImage;
begin
JpegImage:=TJpegImage.Create;
tmpMap:=TImage.Create(nil);
try
tmpMap.Picture.LoadFromFile(sFnBMP);
JpegImage.Assign(tmpMap.Picture.Graphic);
JpegImage.SaveToFile(sFnJPG);
finally
tmpMap.free;
JpegImage.Free;
end;
end;
Function BcdToAsc(Buffer:Pointer; BufferLength:Word):String;
var i:integer; l,h,b:Byte;
s:String;
pc:Pchar;
begin
SetLength(s,2*BufferLength);
pc:=Pchar(Buffer);
for i:=0 to (BufferLength-1) do
begin
b:=Ord(pc[i]);
l:=b AND $0F; //低4位
h:=b shr 4; //高4位
if h<10 then s[2*i+1]:= Chr(Ord('0')+h)
else s[2*i+1]:= Chr(Ord('A')+h-10);
if l<10 then s[2*i+2]:= Chr(Ord('0')+l)
else s[2*i+2]:= Chr(Ord('A')+l-10);
end;
Result:=s;
end;
Function AscToBcd(sAsc:String; len:Integer):String;
Var i:integer; l,h:Byte;
ch:Char; sBcd:String;
begin
Result:='';
if (len mod 2)=1 then Exit;
SetLength(sBcd,(len div 2));
for i:=1 to (len div 2) do
begin
ch:=sAsc[2*i-1];
if ch<='9' then h:=Ord(ch)-Ord('0')
else h:=Ord(ch)-Ord('A')+10;
ch:=sAsc[2*i];
if ch<='9' then l:=Ord(ch)-Ord('0')
else l:=Ord(ch)-Ord('A')+10;
sBcd[i]:=Chr( (h shl 4) +l);
// showmessage(ch+' l='+inttoStr(l)+' bcd='+ intTohex(Ord(sBcd[i]),2));
end;
Result:=sBcd;
end;
Function LapHours(d1,t1,d2,t2:String):double;
Var MyTime,MyDate: TDateTime;
begin
MyTime := EncodeTime(StrToInt(Copy(t2,1,2)),
StrToInt(Copy(t2,4,2)),
StrToInt(Copy(t2,7,2)), 0);
MyDate := EncodeDate(StrToInt(Copy(d2,1,4)),
StrToInt(Copy(d2,6,2)),
StrToInt(Copy(d2,9,2)));
Result:=MyTime+MyDate;
MyTime := EncodeTime(StrToInt(Copy(t1,1,2)),
StrToInt(Copy(t1,4,2)),
StrToInt(Copy(t1,7,2)), 0);
MyDate := EncodeDate(StrToInt(Copy(d1,1,4)),
StrToInt(Copy(d1,6,2)),
StrToInt(Copy(d1,9,2)));
Result:=(Result-MyTime-MyDate)*24;
end;
//合法的小时数字符串
Function LegalHour(sHour:String):String;
Var b,i:integer;
begin
b:=length(sHour)+1;
for i:=1 to length(sHour) do
if (sHour[i]<'0') Or (sHour[i]>'9') then
begin b:=i; break; end; //第一个非数字字符
Result:=Copy(sHour,1,b-1);
if Length(Result)>2 then Result:=Copy(Result,1,2);
if Result='' then Result:='00';
b:=StrToInt(Result);
b:=Min(b,23);
Result:=IntToStr(b);
Result:=Padl(Result,'0',2);
end;
//合法的小时数字符串
Function LegalMinute(sMinute:String):String;
Var b,i:integer;
begin
b:=length(sMinute)+1;
for i:=1 to length(sMinute) do
if (sMinute[i]<'0') Or (sMinute[i]>'9') then
begin b:=i; break; end; //第一个非数字字符
Result:=Copy(sMinute,1,b-1);
if Length(Result)>2 then Result:=Copy(Result,1,2);
if Result='' then Result:='00';
b:=StrToInt(Result);
b:=Min(b,59);
Result:=IntToStr(b);
Result:=Padl(Result,'0',2);
end;
//合法的整数数字字符串
Function LegalInteger(sInteger:String):String;
Var b,i:integer;
s:String;
begin
s:=Trim(sInteger);
b:=length(s)+1;
if (s[1]<>'+') and (s[1]<>'-') then
if (s[1]<'0') Or (s[1]>'9') then
begin Result:='0'; Exit; end;
for i:=2 to length(s) do
if (s[i]<'0') Or (s[i]>'9') then
begin b:=i; break; end; //第一个非数字字符
Result:=Copy(s,1,b-1);
b:=StrToInt(Result);
Result:=IntToStr(b);
end;
//下一个日期的字符串
Function NextDay(dStr:String;Yesterday:Boolean):String;
Var MyDate: TDateTime;
y,m,d:Word;
begin
MyDate := EncodeDate(StrToIntdef(Copy(dStr,1,4),2001),
StrToIntdef(Copy(dStr,5,2),1),
StrToIntdef(Copy(dStr,7,2),1));
if Yesterday then MyDate:=MyDate-1
else MyDate:=MyDate+1;
DecodeDate(MyDate,y,m,d);
Result:=Format('%4.4d%2.2d%2.2d',[y,m,d]);
end;
Function NextDay2(dStr:String;Yesterday:Boolean):String;
Var MyDate: TDateTime;
y,m,d:Word;
begin
MyDate := strtodate(dstr);
{EncodeDate(StrToIntdef(Copy(dStr,1,4),2001),
StrToIntdef(Copy(dStr,5,2),1),
StrToIntdef(Copy(dStr,7,2),1)); }
if Yesterday then MyDate:=MyDate-1
else MyDate:=MyDate+1;
DecodeDate(MyDate,y,m,d);
Result:=Format('%4.4d-%2.2d-%2.2d',[y,m,d]);
end;
//下一个月份的字符串
Function NextMonth(dStr:String):String;
Var y,m:Word;
begin
y:=StrToIntdef(Copy(dStr,1,4),2001);
m:=StrToIntdef(Copy(dStr,5,2),1);
Inc(m);
if m>12 then begin Inc(y); m:=1; end;
Result:=Format('%4.4d%2.2d',[y,m]);
end;
//十六进制字符串转变为二进制字符串'F1'==>'11110001'
Function BinaryStr(HexStr:String):String;
Var i:integer;
s:String;
begin
s:='';
for i:=1 to length(HexStr) do
s:=s+ChrToBinary(HexStr[i]);
Result:=s;
end;
//十六进制字符转变为二进制字符串:'F'==>'1111'
Function ChrToBinary(HexCh:Char):String;
Var d:Word; ch:Char;
i:integer;
s:String;
begin
s:='';
ch:=UpCase(HexCh);
if (ch>='0') and (ch<='9') then d:=Ord(ch)-Ord('0')
else if (ch>='A') and (ch<='F') then
d:=Ord(ch)-Ord('A')+10
else d:=0;
for i:=0 to 3 do
if (d and (1 shl i))>0 then s:='1'+s
else s:='0'+s;
Result:=s;
end;
Procedure AppendOneStrToFile(FileName,Txt:String);//填加一行文本在最后
var f:Text;
begin
{$I-}
Assignfile(f,Filename);
if FileExists(Filename) then Append(f)
else Rewrite(F);
try
Writeln(f, Txt);
finally
Closefile(f);
end;
end;
//把表格中的某行填加到某一文件的最后
Procedure AppendOneRowToFile(Var SG:TStringGrid; Row:LongInt; FileName,AfterHints:String);
var f:Text;
s:String;
begin
{$I-}
Assignfile(f,Filename);
if FileExists(Filename) then Append(f)
else Rewrite(F);
try
StrgridToStr(S,SG,Row);
if AfterHints<>'' then
Writeln(f, S+AfterHints+'^^')
else Writeln(f, S);
finally
Closefile(f);
end;
end;
Function ChangeFileExtName(FileName,NewExtName:String):String;
Var s:String;
i:integer;
begin
i:=Pos('.',FileName);
if i=0 then s:=FileName
else s:=Copy(FileName,1,i-1);
Result:=s+'.'+NewExtName;
end;
//读入日期文件名到表格
Procedure ReadDayFile(Var sg:TStringGrid; Path,SubDir,FileNameExt:String);
Var spath:String;
DayFiles: integer;
SearchRec:TSearchRec;
begin
SG.RowCount :=2;
sPath:=Path+SubDir+'\*.'+FileNameExt;
DayFiles:=FindFirst(sPath,faAnyFile,SearchRec);
try
while DayFiles = 0 do {stop when no more!}
begin
SG.cells[0,SG.RowCount-1]:=NtoD(SearchRec.Name);
DayFiles := FindNext(SearchRec);
if DayFiles = 0 then SG.RowCount :=SG.RowCount+1
else break;
end;
finally
SysUtils.FindClose(SearchRec);
SG.Row:= SG.RowCount-1;
end;
end;
//读入日期文件名到表格
Procedure ReadDayFile2(Var sg:TStringGrid; Path,SubDir,FileNameExt:String);
Var spath:String;
DayFiles: integer;
SearchRec:TSearchRec;
begin
SG.RowCount :=2;
sPath:=Path+SubDir+'\*.'+FileNameExt;
DayFiles:=FindFirst(sPath,faAnyFile,SearchRec);
try
while DayFiles = 0 do {stop when no more!}
begin
SG.cells[0,SG.RowCount-1]:=ChangeFileExt(SearchRec.Name,'');
DayFiles := FindNext(SearchRec);
if DayFiles = 0 then SG.RowCount :=SG.RowCount+1
else break;
end;
finally
SysUtils.FindClose(SearchRec);
SG.Row:= SG.RowCount-1;
end;
end;
//读入日期文件名到表格
Procedure ReadMonthFile(Var sg:TStringGrid; Path,SubDir,FileNameExt:String);
Var spath:String;
DayFiles: integer;
SearchRec:TSearchRec;
begin
SG.RowCount :=2;
sPath:=Path+SubDir+'\*.'+FileNameExt;
DayFiles:=FindFirst(sPath,faAnyFile,SearchRec);
try
while DayFiles = 0 do {stop when no more!}
begin
SG.cells[0,SG.RowCount-1]:=NtoM(SearchRec.Name);
DayFiles := FindNext(SearchRec);
if DayFiles = 0 then SG.RowCount :=SG.RowCount+1
else break;
end;
finally
SysUtils.FindClose(SearchRec);
SG.Row:= SG.RowCount-1;
end;
end;
//删除表格中某列所代表的文件
Procedure DelDayFilesOfGrid(Var SG:TStringGrid; Col:integer;
Path,Subdir,FileExt:String);
Var i,Lo,Hi:integer;
begin
Lo:=SG.Selection.Top;
Hi:=SG.Selection.Bottom;
for i:=Lo to Hi do
if Subdir<>'' then
Mydeletefile(Path+Subdir+'\'+SG.cells[Col,i]+'.'+FileExt)
else
Mydeletefile(Path+DtoN(SG.cells[Col,i])+'.'+FileExt);
end;
Function ReplaceString(S,SubStr,NewStr:String):String;
Var i,j:Integer;
begin
Result:=S;
i:=Pos(substr,S);
if i=0 then Exit;
j:=Length(SubStr);
Result:=Copy(S,1,i-1)+NewStr+Copy(S,i+j,Length(S)-i-j+1);
end;
Function AsciiStr(sNormal:String):String;
Var s:String; i:Integer;
begin
s:='';
for i:=1 to Length(sNormal) do
if sNormal[i]>=' ' then s:=s+sNormal[i];
Result:=s;
end;
Function DelSubString(s,subStr:String):String;
Var i,j:Integer;
begin
Result:=S;
i:=Pos(substr,S);
if i=0 then Exit;
j:=Length(SubStr);
Result:=Copy(S,1,i-1)+Copy(S,i+j,Length(S)-i-j+1);
end;
procedure ReadColor(Var aIniFile:TIniFile;
Sct,Cnt:String; Var r,g,b:Integer);
begin
//假设INI文件已打开
r:=aIniFile.ReadInteger(Sct,Cnt+'R', 255);
g:=aIniFile.ReadInteger(Sct,Cnt+'G', 255);
b:=aIniFile.ReadInteger(Sct,Cnt+'B', 255);
end;
procedure WriteColor(Var aIniFile:TIniFile; Sct,Cnt:String;
Cl:TColor);
begin
try
aIniFile.WriteInteger(Sct,Cnt+'R',GetRValue(Cl));
aIniFile.WriteInteger(Sct,Cnt+'G',GetGValue(Cl));
aIniFile.WriteInteger(Sct,Cnt+'B',GetBValue(Cl));
except
//SysUtils.Beep;
end;
end;
procedure ReadFont(Var aIniFile:TIniFile;
Sct,Cnt:String;
Var sFont:String;
Var fSize,r,g,b:Integer);
begin
sFont:=aIniFile.ReadString(Sct,Cnt+'Name','黑体'); //'楷体_GB2312');
fSize:=aIniFile.ReadInteger(Sct,Cnt+'Size',24);
ReadColor(aIniFile,Sct,Cnt, r,g,b);
end;
procedure WriteFont(Var aIniFile:TIniFile;
Sct,Cnt:String; fFont:TFont);
begin
try
aIniFile.WriteString(Sct,Cnt+'Name',fFont.Name);
aIniFile.WriteInteger(Sct,Cnt+'Size',fFont.Size);
WriteColor(aIniFile,Sct,Cnt,fFont.Color);
except
//SysUtils.Beep;
//showmessage('Can not Write Color');
end;
end;
Function ColorToStr(aColor:TColor):String;
begin
Result:=IntToStr(getRValue(aColor))+';';
Result:=Result+IntToStr(getGValue(aColor))+';';
Result:=Result+IntToStr(getBValue(aColor));
end;
Function StrToColor(sColor:String):TColor;
Var r,g,b:Integer;
begin
r:=StrToIntDef(TextOfIndex(sColor,';',1),255);
g:=StrToIntDef(TextOfIndex(sColor,';',2),255);
b:=StrToIntDef(TextOfIndex(sColor,';',3),255);
Result:=RGB(r,g,b);
end;
//===>宋体;28;1;1;1;fsBold,fsItalic;
Function FontToStr(aFont:TFont):String;
begin
Result:=aFont.Name+';';
Result:=Result+IntToStr(aFont.Size)+';';
Result:=Result+ColorToStr(aFont.Color)+';';
if (fsBold) in aFont.Style then
Result:=Result+'fsBold,';
if fsItalic in aFont.Style then
Result:=Result+'fsItalic';
Result:=Result+';';
end;
procedure StrToFont(sFont:String; Var fFont:TFont);
Var r,g,b:Integer; s:String;
begin
s:=TextOfIndex(sFont,';',1);
if s<>'' then fFont.Name :=s
else fFont.Name :='楷体_GB2312';
s:=TextOfIndex(sFont,';',2);
fFont.Size :=StrToIntDef(s,32);
r:=StrToIntDef(TextOfIndex(sFont,';',3),255);
g:=StrToIntDef(TextOfIndex(sFont,';',4),0);
b:=StrToIntDef(TextOfIndex(sFont,';',5),0);
fFont.Color :=RGB(r,g,b);
s:=TextOfIndex(sFont,';',6);
fFont.Style :=[];
if Pos('fsBold',s)>0 then
fFont.Style := fFont.Style+[fsBold];
if Pos('fsItalic',s)>0 then
fFont.Style := fFont.Style+[fsItalic];
end;
Function MyPower(n:integer):LongInt;
Var i:Integer;
begin
Result:=1;
for i:=0 to n-1 do
Result:=Result*10;
end;
Procedure ShowFmtTxt(aCanvas:TCanvas; fmtTxt,YourHint: String);
Var XX,YY,Deepth,EdgeDeep,Reduce:Integer;
sItem,FText:String;
FRoundColor:TColor;
LF:TLogFont;
NewFont,OldFont:HFont;
DC:THandle;
i,j,n,deep,FAngle:Integer;
r,g,b:Byte;
FFont:TFont;
begin
sItem:=fmtTxt;
if YourHint='' then
FText:=TextOfIndex(sItem,'~~',1)
else
FText:=YourHint;
XX:=StrToIntDef(TextOfIndex(sItem,'~~',2),200);
YY:=StrToIntDef(TextOfIndex(sItem,'~~',3),400);
FAngle:=StrToIntDef(TextOfIndex(sItem,'~~',4),0);
FFont:=TFont.Create;
StrToFont(TextOfIndex(sItem,'~~',5),FFont);
aCanvas.Font:=FFont;
FFont.Free;
FRoundColor:=utPublic.StrToColor(TextOfIndex(sItem,'~~',6));
EdgeDeep:=StrToIntDef(TextOfIndex(sItem,'~~',7),1); //钩边
Deepth:=StrToIntDef(TextOfIndex(sItem,'~~',8),0); //立体
DC:=aCanvas.Handle;
r:=GetRValue(FRoundColor);
g:=GetGValue(FRoundColor);
b:=GetBValue(FRoundColor);
for n:=Abs(Deepth) downto 0 do
with LF,aCanvas.Font do //立体
begin
if Deepth<0 then deep:=-n
else deep:=n;
lfHeight:=Height;
lfWidth:=0;
lfEscapement:=FAngle;
lfOrientation:=FAngle;
if fsBold in Style then
lfWeight:=FW_Bold
else
lfWeight:=FW_Normal;
lfItalic:=Byte(fsItalic in Style);
lfUnderline:=Byte(fsUnderline in Style);
lfStrikeOut:=Byte(fsStrikeOut in Style);
lfCharSet:=Byte(CharSet);
lfOutPrecision:=Out_Default_Precis;
lfClipPrecision:=Clip_Default_Precis;
lfQuality:=Default_Quality;
case Pitch of
fpVariable:lfPitchAndFamily:=Variable_Pitch;
fpFixed:lfPitchAndFamily:=Fixed_Pitch
else
lfPitchAndFamily:=Default_Pitch
end;
StrPCopy(lfFaceName,Name);
SetBkMode(DC,Transparent);
NewFont:=CreateFontIndirect(LF);
OldFont:=SelectObject(DC,NewFont);
for i:= EdgeDeep downto 1 do //处理钩边色
begin
reduce:=trunc(Power(3,i-1));
SetBkMode(DC,Transparent);
SetTextColor(DC,RGB(r div reduce,g div reduce,b div reduce));
for j:=1 to i do
TextOut(DC,XX-i+j+Deep,
YY-j+Deep,PChar(FText),Length(FText));
for j:=1 to i do
TextOut(DC,XX+j+Deep,YY-i+j+Deep,PChar(FText),Length(FText));
for j:=1 to i do
TextOut(DC,XX+i-j+Deep,YY+j+Deep,PChar(FText),Length(FText));
for j:=1 to i do
TextOut(DC,XX-j+Deep,YY+i-j+Deep,PChar(FText),Length(FText));
end;
SetBkMode(DC,Transparent);
SetTextColor(DC,ColorToRGB(acanvas.Font.Color));
TextOut(DC,XX+Deep,YY+Deep,PChar(FText),Length(FText));
SelectObject(DC,OldFont);
DeleteObject(NewFont);
aCanvas.TextOut(100,100,'');
end;
end;
Procedure ShowFmtTxtRect(aCanvas,backCanvas:TCanvas; fmtTxt,YourHint: String);
Var XX,YY,W,H,Deepth,EdgeDeep:Integer; aRect:TRect;
sItem,FText:String; FFont:TFont;
begin
sItem:=fmtTxt;
if YourHint='' then
FText:=TextOfIndex(sItem,'~~',1)
else
FText:=YourHint;
XX:=StrToIntDef(TextOfIndex(sItem,'~~',2),200);
YY:=StrToIntDef(TextOfIndex(sItem,'~~',3),400);
EdgeDeep:=StrToIntDef(TextOfIndex(sItem,'~~',7),1); //钩边
Deepth:=StrToIntDef(TextOfIndex(sItem,'~~',8),0); //立体
if EdgeDeep<Deepth then EdgeDeep:=Deepth;
FFont:=TFont.Create;
StrToFont(TextOfIndex(sItem,'~~',5),FFont);
aCanvas.Font:=FFont;
FFont.Free;
W:=aCanvas.TextWidth(FText);
H:=aCanvas.TextHeight(FText);
aRect:=Rect(XX-EdgeDeep,YY-EdgeDeep,XX+W+EdgeDeep,YY+H+EdgeDeep);
aCanvas.CopyRect(aRect,backCanvas,aRect);
ShowFmtTxt(aCanvas,fmtTxt,YourHint);
end;
Procedure ShowFmtTxtRight(aCanvas,BackCanvas:TCanvas; fmtTxt,YourHint: String);
Var XX,YY,H,Deepth,EdgeDeep:Integer; aRect:TRect;
sItem,FText:String; FFont:TFont;
begin
sItem:=fmtTxt;
if YourHint='' then
FText:=TextOfIndex(sItem,'~~',1)
else
FText:=YourHint;
XX:=StrToIntDef(TextOfIndex(sItem,'~~',2),200);
YY:=StrToIntDef(TextOfIndex(sItem,'~~',3),400);
EdgeDeep:=StrToIntDef(TextOfIndex(sItem,'~~',7),1); //钩边
Deepth:=StrToIntDef(TextOfIndex(sItem,'~~',8),0); //立体
if EdgeDeep<Deepth then EdgeDeep:=Deepth;
FFont:=TFont.Create;
StrToFont(TextOfIndex(sItem,'~~',5),FFont);
aCanvas.Font:=FFont;
FFont.Free;
H:=aCanvas.TextHeight(FText);
aRect:=Rect(XX-EdgeDeep,YY-EdgeDeep,1024,YY+H+EdgeDeep);
aCanvas.CopyRect(aRect,BackCanvas,aRect);
ShowFmtTxt(aCanvas,fmtTxt,YourHint);
end;
procedure WriteOnePara(sIniFile,Sct,Idt,Value:String);
Var aIniFile:TIniFile;
begin
aIniFile:=TIniFile.Create(sIniFile);
try
aIniFile.WriteString(Sct,Idt,Value);
finally
aIniFile.Free;
end;
end;
Function ReadOnePara(sIniFile,Sct,Idt:String):String;
Var aIniFile:TIniFile;
begin
Result:='';
aIniFile:=TIniFile.Create(sIniFile);
try
Result:=aIniFile.ReadString(Sct,Idt,'');
finally
aIniFile.Free;
end;
end;
//十六进制字符串转换为字节指针（'4142FF'-->$41$42$FF）
Function HexStrToPchar(hs:String; ptr:Pchar):Word;
Var i,n,ln:integer;
s:String;
ch1,ch2:Char;
begin
ln:=length(hs) div 2;
s:=uppercase(hs);
for i:=1 to ln do
begin
ch1:=s[2*i-1];
ch2:=s[2*i];
if (ch1>='0') and (ch1<='9') then
n:=Ord(ch1)-Ord('0')
else n:=Ord(ch1)-Ord('A')+10;
n:=n*16;
if (ch2>='0') and (ch2<='9') then
n:=n+Ord(ch2)-Ord('0')
else n:=n+Ord(ch2)-Ord('A')+10;
ptr[i-1]:=Chr(n);
end;
ptr[ln]:=chr(0);
Result:=ln;
end;
//转换为十六进制字符串
Function StrToHexStr(Buffer: Pointer; BufferLength: Word):String;
Var i:integer;
s:String;
p:Pchar;
begin
s:='';
p:=Pchar(Buffer);
for i:=0 to BufferLength-1 do
s:=s+IntToHex(Ord(p[i]),2);
Result:=s;
end;
//合法数字字符串
Function LegalNumber(s:String):String;
Var b,i:integer;
begin
b:=length(s)+1;
for i:=1 to length(s) do
if (s[i]<'0') Or (s[i]>'9') then
begin b:=i; break; end; //第一个非数字字符
Result:=Copy(s,1,b-1);
end;
//-----返回高度和-----//
Function MakeRows(aCanvas:TCanvas; s:String; Var sList:TStringList):Integer;
Var i,n:Integer;
begin
i:=1; n:=Length(s);
sList.Clear;
while True do
begin
if i>n then Break;
if s[i]>Chr(128) then
begin
sList.Add(s[i]+s[i+1]);
Inc(i,2); //一个汉字两个字节,占一行
end
else
begin
Inc(i);
sList.Add(s[i-1]);
end;
end;
Result:=0; //高度
if sList.Count>0 then
Result:= sList.Count*aCanvas.TextHeight(sList.Strings[0]);
end;
//---------在画布的矩形区垂直显示文字,自动调节文字大小---------//
Procedure MyTextOutV(aCanvas:TCanvas; //画布
x,y:Integer; //在中间位置显示
sList:TStringList); //显示文字
Var nRow,i,tW,tH:Integer;
begin
//----先计算分成多少行及每行的高度--------//
nRow:=sList.Count;
if nRow<1 then Exit;
tH:=aCanvas.TextHeight(sList.Strings[0]); //一行文字高度
//aCanvas.Brush.Style:=bsClear;
for i:=0 to nRow-1 do
begin
//setbkmode(aCanvas.Handle,TRANSPARENT);
tW:=aCanvas.TextWidth(sList.Strings[i]);
//aCanvas.TextOut((x-tW) div 2,y+i*tH, sList.Strings[i]);
aCanvas.TextOut(0,y+i*tH, sList.Strings[i]);
end;
end;
Function PartColor(cl:TColor; nPart:Real):TColor;
begin
Result:=RGB(Trunc(GetRValue(cl)/nPart),
Trunc(GetGValue(cl)/nPart),
Trunc(GetBValue(cl)/nPart));
end;
procedure DrawLineH3(x,y,len:Integer;aCanvas:TCanvas;
cl:TColor;direction:Integer);
begin
with aCanvas do
case direction of
dUp: begin
//Pen.Color :=PartColor(cl,2.3);
//Moveto(x+2,y-2); lineTo(x+len-2,y-2);
Pen.Color :=PartColor(cl,2);
Moveto(x+1,y-1); lineTo(x+len-1,y-1);
Pen.Color :=cl;
Moveto(x,y); lineTo(x+len,y);
Pen.Color :=PartColor(cl,2);
Moveto(x-1,y+1); lineTo(x+len+1,y+1);
//Pen.Color :=PartColor(cl,2.3);
//Moveto(x-2,y+2); lineTo(x+len+2,y+2);
end;
dDown: begin
//Pen.Color :=PartColor(cl,2.3);
//Moveto(x-2,y-2); lineTo(x+len+2,y-2);
Pen.Color :=PartColor(cl,2);
Moveto(x-1,y-1); lineTo(x+len+1,y-1);
Pen.Color :=cl;
Moveto(x,y); lineTo(x+len,y);
Pen.Color :=PartColor(cl,2);
Moveto(x+1,y+1); lineTo(x+len-1,y+1);
//Pen.Color :=PartColor(cl,2.3);
//Moveto(x+2,y+2); lineTo(x+len-2,y+2);
end;
else begin
//Pen.Color :=PartColor(cl,2.3);
//Moveto(x,y-2); lineTo(x+len,y-2);
Pen.Color :=PartColor(cl,2);
Moveto(x,y-1); lineTo(x+len,y-1);
Pen.Color :=cl;
Moveto(x,y); lineTo(x+len,y);
Pen.Color :=PartColor(cl,2);
Moveto(x,y+1); lineTo(x+len,y+1);
//Pen.Color :=PartColor(cl,2.3);
//Moveto(x,y+2); lineTo(x+len,y+2);
end;
end;
end;
procedure DrawLineH(x,y,len:Integer;aCanvas:TCanvas;
cl:TColor;direction:Integer);
begin
with aCanvas do
case direction of
dUp: begin
Pen.Color :=PartColor(cl,2.3);
Moveto(x+2,y-2); lineTo(x+len-2,y-2);
Pen.Color :=PartColor(cl,2);
Moveto(x+1,y-1); lineTo(x+len-1,y-1);
Pen.Color :=cl;
Moveto(x,y); lineTo(x+len,y);
Pen.Color :=PartColor(cl,2);
Moveto(x-1,y+1); lineTo(x+len+1,y+1);
Pen.Color :=PartColor(cl,2.3);
Moveto(x-2,y+2); lineTo(x+len+2,y+2);
end;
dDown: begin
Pen.Color :=PartColor(cl,2.3);
Moveto(x-2,y-2); lineTo(x+len+2,y-2);
Pen.Color :=PartColor(cl,2);
Moveto(x-1,y-1); lineTo(x+len+1,y-1);
Pen.Color :=cl;
Moveto(x,y); lineTo(x+len,y);
Pen.Color :=PartColor(cl,2);
Moveto(x+1,y+1); lineTo(x+len-1,y+1);
Pen.Color :=PartColor(cl,2.3);
Moveto(x+2,y+2); lineTo(x+len-2,y+2);
end;
else begin
Pen.Color :=PartColor(cl,2.3);
Moveto(x,y-2); lineTo(x+len,y-2);
Pen.Color :=PartColor(cl,2);
Moveto(x,y-1); lineTo(x+len,y-1);
Pen.Color :=cl;
Moveto(x,y); lineTo(x+len,y);
Pen.Color :=PartColor(cl,2);
Moveto(x,y+1); lineTo(x+len,y+1);
Pen.Color :=PartColor(cl,2.3);
Moveto(x,y+2); lineTo(x+len,y+2);
end;
end;
end;
procedure DrawLineH2(x,y,len:Integer;aCanvas:TCanvas;
cl,clBack:TColor;direction:Integer);
begin
with aCanvas do
case direction of
dUp: begin
Pen.Color :=PartColor(cl,1);
Moveto(x-4,y+4); lineTo(x+len+4,y+4);
Pen.Color :=PartColor(cl,1.5);
Moveto(x-3,y+3); lineTo(x+len+3,y+3);
Pen.Color :=PartColor(cl,2.3);
Moveto(x-2,y+2); lineTo(x+len+2,y+2);
Pen.Color :=clBack;
Moveto(x-1,y+1); lineTo(x+len+1,y+1);
Moveto(x,y); lineTo(x+len,y);
Moveto(x+1,y-1); lineTo(x+len-1,y-1);
Pen.Color :=cl;
Moveto(x+2,y-2); lineTo(x+len-2,y-2);
Pen.Color :=PartColor(cl,1.5);
Moveto(x+3,y-3); lineTo(x+len-3,y-3);
Pen.Color :=PartColor(cl,2.3);
Moveto(x+4,y-4); lineTo(x+len-4,y-4);
Pen.Color :=PartColor(cl,3);
Moveto(x+5,y-5); lineTo(x+len-5,y-5);
end;
dDown: begin
Pen.Color :=PartColor(cl,1);
Moveto(x-4,y-4); lineTo(x+len+4,y-4);
Pen.Color :=PartColor(cl,1.5);
Moveto(x-3,y-3); lineTo(x+len+3,y-3);
Pen.Color :=PartColor(cl,2.3);
Moveto(x-2,y-2); lineTo(x+len+2,y-2);
Pen.Color :=clBack;
Moveto(x-1,y-1); lineTo(x+len+1,y-1);
Moveto(x,y); lineTo(x+len,y);
Moveto(x+1,y+1); lineTo(x+len-1,y+1);
Pen.Color :=PartColor(cl,1);
Moveto(x+2,y+2); lineTo(x+len-2,y+2);
Pen.Color :=PartColor(cl,1.5);
Moveto(x+3,y+3); lineTo(x+len-3,y+3);
Pen.Color :=PartColor(cl,2.3);
Moveto(x+4,y+4); lineTo(x+len-4,y+4);
Pen.Color :=PartColor(cl,3);
Moveto(x+5,y+5); lineTo(x+len-5,y+5);
end;
else begin
Pen.Color :=cl;
Moveto(x,y-4); lineTo(x+len,y-4);
Pen.Color :=PartColor(cl,1.5);
Moveto(x,y-3); lineTo(x+len,y-3);
Pen.Color :=PartColor(cl,2);
Moveto(x,y-2); lineTo(x+len,y-2);
Pen.Color :=clBack;
Moveto(x,y-1); lineTo(x+len,y-1);
Moveto(x,y); lineTo(x+len,y);
Moveto(x,y+1); lineTo(x+len,y+1);
Pen.Color :=PartColor(cl,2);
Moveto(x,y+2); lineTo(x+len,y+2);
Pen.Color :=PartColor(cl,1.5);
Moveto(x,y+3); lineTo(x+len,y+3);
Pen.Color :=cl;
Moveto(x,y+4); lineTo(x+len,y+4);
end;
end;
end;
procedure DrawLineV(x,y,len:Integer;aCanvas:TCanvas;
cl:TColor;direction:Integer);
begin
with aCanvas do
case direction of
dLeft: begin
Pen.Color :=PartColor(cl,2.3);
Moveto(x-2,y+2); lineTo(x-2,y+len-2);
Pen.Color :=PartColor(cl,2);
Moveto(x-1,y+1); lineTo(x-1,y+len-1);
Pen.Color :=cl;
Moveto(x,y); lineTo(x,y+len);
Pen.Color :=PartColor(cl,2);
Moveto(x+1,y-1); lineTo(x+1,y+len+1);
Pen.Color :=PartColor(cl,2.3);
Moveto(x+2,y-2); lineTo(x+2,y+len+2);
end;
dRight: begin
Pen.Color :=PartColor(cl,2.3);
Moveto(x-2,y-2); lineTo(x-2,y+len+2);
Pen.Color :=PartColor(cl,2);
Moveto(x-1,y-1); lineTo(x-1,y+len+1);
Pen.Color :=cl;
Moveto(x,y); lineTo(x,y+len);
Pen.Color :=PartColor(cl,2);
Moveto(x+1,y+1); lineTo(x+1,y+len-1);
Pen.Color :=PartColor(cl,2.3);
Moveto(x+2,y+2); lineTo(x+2,y+len-2);
end;
else begin
Pen.Color :=PartColor(cl,2.3);
Moveto(x-2,y); lineTo(x-2,y+len);
Pen.Color :=PartColor(cl,2);
Moveto(x-1,y); lineTo(x-1,y+len);
Pen.Color :=cl;
Moveto(x,y); lineTo(x,y+len);
Pen.Color :=PartColor(cl,2);
Moveto(x+1,y); lineTo(x+1,y+len);
Pen.Color :=PartColor(cl,2.3);
Moveto(x+2,y); lineTo(x+2,y+len);
end;
end;
end;
procedure DrawLineV2(x,y,len:Integer;aCanvas:TCanvas;
cl,clBack:TColor;direction:Integer);
begin
with aCanvas do
case direction of
dLeft: begin
Pen.Color :=PartColor(cl,3);
Moveto(x-5,y+5); lineTo(x-5,y+len-5);
Pen.Color :=PartColor(cl,2.3);
Moveto(x-4,y+4); lineTo(x-4,y+len-4);
Pen.Color :=PartColor(cl,1.5);
Moveto(x-3,y+3); lineTo(x-3,y+len-3);
Pen.Color :=PartColor(cl,1);
Moveto(x-2,y+2); lineTo(x-2,y+len-2);
Pen.Color :=clBack;
Moveto(x-1,y+1); lineTo(x-1,y+len-1);
Moveto(x,y); lineTo(x,y+len);
Moveto(x+1,y-1); lineTo(x+1,y+len+1);
Pen.Color :=PartColor(cl,2.3);
Moveto(x+2,y-2); lineTo(x+2,y+len+2);
Pen.Color :=PartColor(cl,1.5);
Moveto(x+3,y-3); lineTo(x+3,y+len+3);
Pen.Color :=PartColor(cl,1);
Moveto(x+4,y-4); lineTo(x+4,y+len+4);
end;
dRight: begin
Pen.Color :=PartColor(cl,3);
Moveto(x+5,y+5); lineTo(x+5,y+len-5);
Pen.Color :=PartColor(cl,2.3);
Moveto(x+4,y+4); lineTo(x+4,y+len-4);
Pen.Color :=PartColor(cl,1.5);
Moveto(x+3,y+3); lineTo(x+3,y+len-3);
Pen.Color :=PartColor(cl,1);
Moveto(x+2,y+2); lineTo(x+2,y+len-2);
Pen.Color :=clBack;
Moveto(x+1,y+1); lineTo(x+1,y+len-1);
Moveto(x,y); lineTo(x,y+len);
Moveto(x-1,y-1); lineTo(x-1,y+len+1);
Pen.Color :=PartColor(cl,2.3);
Moveto(x-2,y-2); lineTo(x-2,y+len+2);
Pen.Color :=PartColor(cl,1.5);
Moveto(x-3,y-3); lineTo(x-3,y+len+3);
Pen.Color :=PartColor(cl,1);
Moveto(x-4,y-4); lineTo(x-4,y+len+4);
end;
else begin
Pen.Color :=cl;
Moveto(x+4,y); lineTo(x+4,y+len);
Pen.Color :=PartColor(cl,1.5);
Moveto(x+3,y); lineTo(x+3,y+len);
Pen.Color :=PartColor(cl,2);
Moveto(x+2,y); lineTo(x+2,y+len);
Pen.Color :=clBack;
Moveto(x+1,y); lineTo(x+1,y+len);
Moveto(x,y); lineTo(x,y+len);
Moveto(x-1,y); lineTo(x-1,y+len);
Pen.Color :=PartColor(cl,2);
Moveto(x-2,y); lineTo(x-2,y+len);
Pen.Color :=PartColor(cl,1.5);
Moveto(x-3,y); lineTo(x-3,y+len);
Pen.Color :=cl;
Moveto(x-4,y); lineTo(x-4,y+len);
end;
end;
end;
procedure Rectangle3D(l,t,r,b:Integer;aCanvas:TCanvas;cl:TColor);
begin
DrawLineH(l,t,r-l+1,aCanvas,cl,dDown);
DrawLineH(l,b,r-l+1,aCanvas,cl,dUp);
DrawLineV(l,t,b-t+1,aCanvas,cl,dRight);
DrawLineV(r,t,b-t+1,aCanvas,cl,dLeft);
end;
procedure Rectangle3D2(l,t,r,b:Integer;aCanvas:TCanvas;cl,clBack:TColor);
begin
DrawLineH2(l,t,r-l+1,aCanvas,cl,clBack,dDown);
DrawLineH2(l,b,r-l+1,aCanvas,cl,clBack,dUp);
DrawLineV2(l,t,b-t+1,aCanvas,cl,clBack,dRight);
DrawLineV2(r,t,b-t+1,aCanvas,cl,clBack,dLeft);
end;
Function MyStrToFloatDef(s:String; default:Real):Real;
begin
try
if s='' then Result:=0.0
else Result:=StrToFloat(s);
except
on E: EConvertError do
Result:=default;
end;
end;
//删除特定型号
procedure DelOneDevice(devFile:String;sType:String);
Var aIniFile:TIniFile;
begin
aIniFile:=TIniFile.Create(devFile);
try
aIniFile.EraseSection(sType);
finally
aIniFile.Free;
end;
end;
//-----------把一个表格存盘到INI文件中-------------------//
procedure WriteGridToINI(sFile,Sect:String;sg:TStringGrid);
Var i:integer;
s:String;
begin
{$I-}
DelOneDevice(sFile,Sect);
for i:=0 to SG.RowCount-1 do
begin
StrgridToStr(S,SG,i);
WriteOnePara(sFile,Sect,'Row'+IntToStr(i),s);
end;
end;
//-----------从INI文件中读表格数据某行-------------------//
procedure ReadINIToGridRow(sFile,Sect:String;Var sg:TStringGrid; nRow:integer);
Var i,n:integer;
s:String;
begin
{$I-}
s:=ReadOnePara(sFile,Sect,'Row'+IntToStr(nRow));
if s='' then Exit;
n:=GetcolCount(s);
n:=min(n,sg.ColCount);
for i:=1 to n-1 do
sg.Cells[i,nRow]:=TextofIndex(s,'^^',i+1);
end;
//-----------从INI文件中读表格数据某行-------------------//
procedure ReadINIToGridCol(sFile,Sect:String;Var sg:TStringGrid; nCol:integer);
Var i:integer;
s:String;
begin
{$I-}
if nCol>=sg.ColCount then Exit;
for i:=1 to sg.RowCount-1 do
begin
s:=ReadOnePara(sFile,Sect,'Row'+IntToStr(i));
sg.Cells[nCol,i]:=TextofIndex(s,'^^',nCol+1);
end;
end;
//-----------从INI文件中读表格数据-------------------//
procedure ReadINIToGrid(sFile,Sect:String;Var sg:TStringGrid);
Var i,n:integer;
s:String;
begin
{$I-}
i:=0;
while True do
begin
s:=ReadOnePara(sFile,Sect,'Row'+IntToStr(i));
if s='' then Break;
if i=0 then
begin
n:=GetcolCount(s);
if sg.ColCount<n then sg.ColCount:=n;
end;
Inc(i);
if SG.RowCount<i then
SG.RowCount :=i;
StrToStrgrid(s,sg,i-1);
end;
end;
Function NormalTime(sTime:String):String;
begin
Result:=SecondToTimeStr(TimeStrToSecond(sTime,':'));
end;
//------------------得到设备名称列表-----------------//
procedure GetDevTable(sdgParaFile:String;cbType:TComboBox);
Var
aIniFile:TIniFile; i:Integer;
slst:TStringList;
begin
cbType.Clear;
try
slst:=TStringList.Create;
aIniFile:=TIniFile.Create(sdgParaFile);
aIniFile.ReadSections(slst);
for i:=0 to slst.Count -1 do
cbType.Items.Add(slst[i]);
finally
aIniFile.Free;
slst.Free;
end;
end;
Procedure AddOneCol(Var SG:TStringGrid);
begin
if sg.Cells[0,1]='' then //Second Line is empty
begin
sg.ColCount:=1;
sg.Col:=0;
end
else
begin
sg.ColCount :=sg.ColCount+1;
sg.Col:=sg.ColCount-1;
sg.Cols[sg.ColCount-1].clear;
end;
end;
Procedure TwoSgCopyOneCol(Var SrcSG:TStringGrid; Col1:integer;
Var DestSG:TStringGrid; Col2:integer);
Var i:integer;
begin
if DestSG.RowCount<SrcSG.RowCount then DestSG.RowCount:=SrcSG.RowCount;
for i:=0 to SrcSG.RowCount -1 do
TwoSgCopyOneCell(SrcSG,Col1,i,DestSG,Col2,i);
end;
Procedure MyFmtTextOutH(ss:String; //显示文字
align:Integer; //对齐方式
aCanvas:TCanvas; //画布
aRect:TRect; //显示区域
edge:Byte); //边框宽度
Var tW,tH,rW,rH:Integer;
s,fmtS:String;
begin
if ss='' then s:=' '
else s:=ss;
rW:=aRect.Right -aRect.Left-2; //矩形区宽
rH:=aRect.Bottom -aRect.Top-2; //矩形区高
tW:=aCanvas.TextWidth(s); //文字宽度
tH:=aCanvas.TextHeight(s); //文字高度
//------先调整高度---------//
if tH>rH then
while True do
begin
aCanvas.Font.Size :=aCanvas.Font.Size-1;
if aCanvas.Font.Size<3 THEN Break;
tH:=aCanvas.TextHeight(s); //文字新高度
if tH<=rH then break;
end;
tW:=aCanvas.TextWidth(s); //文字宽度
tH:=aCanvas.TextHeight(s); //文字高度
//------在调整宽度---------//
if tW>rW then
while True do
begin
aCanvas.Font.Size :=aCanvas.Font.Size-1;
if aCanvas.Font.Size<3 THEN Break;
tW:=aCanvas.TextWidth(s); //文字新高度
if tW<=rW then break;
end;
tW:=aCanvas.TextWidth(s); //文字宽度
tH:=aCanvas.TextHeight(s); //文字高度
aCanvas.Brush.Style:=bsClear;
setbkmode(aCanvas.Handle,TRANSPARENT);
if align=0 then //左对齐
// '文字~~80~~10~~0~~宋体;18;255;255;0;~~64;64;64;~~2~~0';
fmts:=s+'~~'+inttostr(aRect.Left+1)+'~~'+inttostr(aRect.top+1+(rH-tH) div 2)
else if align=1 then //中间对齐
fmts:=s+'~~'+inttostr(aRect.Left+(rW-tW) div 2)+'~~'+inttostr(aRect.top+1+(rH-tH) div 2)
//aCanvas.TextOut(aRect.Left+(rW-tW) div 2,aRect.top+1+(rH-tH) div 2,s)
else
fmts:=s+'~~'+inttostr(aRect.Left+rW-tW)+'~~'+inttostr(aRect.top+1+(rH-tH) div 2);
//aCanvas.TextOut(aRect.Left+rW-tW, aRect.top+1+(rH-tH) div 2,s);
fmts:=fmts+'~~0~~'+FontToStr(aCanvas.font);
fmts:=fmts+'~~32;32;32;~~'+inttostr(edge)+'~~0';
ShowFmtTxt(aCanvas,fmtS,'');
end;
Function StrToBool(s:String):Boolean;
begin
if (uppercase(s)='YES') OR (uppercase(s)='TRUE') then
Result:=True
else
Result:=False;
end;
Function boolStr(bo:Boolean):String;
begin
if bo then result:='YES' else result:='NO';
end;
function GetIdeDiskSerialNumber(var SerialNumber: string; var ModelNumber: string;
var FirmwareRev: string):Boolean; //得到硬盘物理号
var TotalAddressableSectors: ULong;
SectorCapacity: ULong;
SectorsPerTrack: Word;
type
TSrbIoControl = packed record
HeaderLength: ULong;
Signature: array[0..7] of Char;
Timeout: ULong;
ControlCode: ULong;
ReturnCode: ULong;
Length: ULong;
end;
SRB_IO_CONTROL = TSrbIoControl;
PSrbIoControl = ^TSrbIoControl;
TIDERegs = packed record
bFeaturesReg: Byte; // Used for specifying SMART "commands".
bSectorCountReg: Byte; // IDE sector count register
bSectorNumberReg: Byte; // IDE sector number register
bCylLowReg: Byte; // IDE low order cylinder value
bCylHighReg: Byte; // IDE high order cylinder value
bDriveHeadReg: Byte; // IDE drive/head register
bCommandReg: Byte; // Actual IDE command.
bReserved: Byte; // reserved. Must be zero.
end;
IDEREGS = TIDERegs;
PIDERegs = ^TIDERegs;
TSendCmdInParams = packed record
cBufferSize: DWORD;
irDriveRegs: TIDERegs;
bDriveNumber: Byte;
bReserved: array[0..2] of Byte;
dwReserved: array[0..3] of DWORD;
bBuffer: array[0..0] of Byte;
end;
SENDCMDINPARAMS = TSendCmdInParams;
PSendCmdInParams = ^TSendCmdInParams;
TIdSector = packed record
wGenConfig: Word;
wNumCyls: Word;
wReserved: Word;
wNumHeads: Word;
wBytesPerTrack: Word;
wBytesPerSector: Word;
wSectorsPerTrack: Word;
wVendorUnique: array[0..2] of Word;
sSerialNumber: array[0..19] of Char;
wBufferType: Word;
wBufferSize: Word;
wECCSize: Word;
sFirmwareRev: array[0..7] of Char;
sModelNumber: array[0..39] of Char;
wMoreVendorUnique: Word;
wDoubleWordIO: Word;
wCapabilities: Word;
wReserved1: Word;
wPIOTiming: Word;
wDMATiming: Word;
wBS: Word;
wNumCurrentCyls: Word;
wNumCurrentHeads: Word;
wNumCurrentSectorsPerTrack: Word;
ulCurrentSectorCapacity: ULong;
wMultSectorStuff: Word;
ulTotalAddressableSectors: ULong;
wSingleWordDMA: Word;
wMultiWordDMA: Word;
bReserved: array[0..127] of Byte;
end;
PIdSector = ^TIdSector;
const
IDE_ID_FUNCTION = $EC;
IDENTIFY_BUFFER_SIZE = 512;
DFP_RECEIVE_DRIVE_DATA = $0007C088;
IOCTL_SCSI_MINIPORT = $0004D008;
IOCTL_SCSI_MINIPORT_IDENTIFY = $001B0501;
DataSize = sizeof(TSendCmdInParams) - 1 + IDENTIFY_BUFFER_SIZE;
BufferSize = sizeof(SRB_IO_CONTROL) + DataSize;
W9xBufferSize = IDENTIFY_BUFFER_SIZE + 16;
var
hDevice: THandle;
cbBytesReturned: DWORD;
pInData: PSendCmdInParams;
pOutData: Pointer; // PSendCmdOutParams
Buffer: array[0..BufferSize - 1] of Byte;
srbControl: TSrbIoControl absolute Buffer;
winpath:String;
procedure ChangeByteOrder(var Data; Size: Integer);
var ptr: PChar;
i: Integer;
c: Char;
begin
ptr := @Data;
for i := 0 to (Size shr 1) - 1 do
begin
c := ptr^;
ptr^ := (ptr + 1)^;
(ptr + 1)^ := c;
Inc(ptr, 2);
end;
end;
begin
Result := False;
FillChar(Buffer, BufferSize, #0);
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin // Windows NT, Windows 2000
// Get SCSI port handle
hDevice := CreateFile('\\.\Scsi0:',
GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE,
nil, OPEN_EXISTING, 0, 0);
if hDevice = INVALID_HANDLE_VALUE then Exit;
try
srbControl.HeaderLength := sizeof(SRB_IO_CONTROL);
System.Move('SCSIDISK', srbControl.Signature, 8);
srbControl.Timeout := 2;
srbControl.Length := DataSize;
srbControl.ControlCode := IOCTL_SCSI_MINIPORT_IDENTIFY;
pInData := PSendCmdInParams(PChar(@Buffer)
+ sizeof(SRB_IO_CONTROL));
pOutData := pInData;
with pInData^ do
begin
cBufferSize := IDENTIFY_BUFFER_SIZE;
bDriveNumber := 0;
with irDriveRegs do
begin
bFeaturesReg := 0;
bSectorCountReg := 1;
bSectorNumberReg := 1;
bCylLowReg := 0;
bCylHighReg := 0;
bDriveHeadReg := $A0;
bCommandReg := IDE_ID_FUNCTION;
end;
end;
if not DeviceIoControl(hDevice, IOCTL_SCSI_MINIPORT,
@Buffer, BufferSize, @Buffer, BufferSize,
cbBytesReturned, nil) then Exit;
finally
CloseHandle(hDevice);
end;
end
else
begin // Windows 95 OSR2, Windows 98
// Smartvsd.vxd 在system\Iosubsys目录下
//UINT GetSystemDirectory( LPTSTR lpBuffer, UINT uSize);
hDevice := CreateFile('\\.\SMARTVSD', 0, 0, nil,
CREATE_NEW, 0, 0);
if hDevice = INVALID_HANDLE_VALUE then Exit;
try
pInData := PSendCmdInParams(@Buffer);
pOutData := @pInData^.bBuffer;
with pInData^ do
begin
cBufferSize := IDENTIFY_BUFFER_SIZE;
bDriveNumber := 0;
with irDriveRegs do
begin
bFeaturesReg := 0;
bSectorCountReg := 1;
bSectorNumberReg := 1;
bCylLowReg := 0;
bCylHighReg := 0;
bDriveHeadReg := $A0;
bCommandReg := IDE_ID_FUNCTION;
end;
end;
if not DeviceIoControl(hDevice, DFP_RECEIVE_DRIVE_DATA,
pInData, sizeof(TSendCmdInParams) - 1, pOutData,
W9xBufferSize, cbBytesReturned, nil) then Exit;
finally
CloseHandle(hDevice);
end;
end;
with PIdSector(PChar(pOutData) + 16)^ do
begin
ChangeByteOrder(sSerialNumber, sizeof(sSerialNumber));
SetString(SerialNumber, sSerialNumber, sizeof(sSerialNumber)); //硬盘生产序号
ChangeByteOrder(sModelNumber, sizeof(sModelNumber));
SetString(ModelNumber, sModelNumber, sizeof(sModelNumber)); //硬盘型号
ChangeByteOrder(sFirmwareRev, sizeof(sFirmwareRev));
SetString(FirmwareRev, sFirmwareRev, sizeof(sFirmwareRev)); //硬盘硬件版本
Result := True;
ChangeByteOrder(ulTotalAddressableSectors, sizeof(ulTotalAddressableSectors));
TotalAddressableSectors := ulTotalAddressableSectors; //硬盘ulTotalAddressableSectors参数
ChangeByteOrder(ulCurrentSectorCapacity, sizeof(ulCurrentSectorCapacity));
SectorCapacity := ulCurrentSectorCapacity; //硬盘wBytesPerSector参数
ChangeByteOrder(wNumCurrentSectorsPerTrack, sizeof(wNumCurrentSectorsPerTrack));
SectorsPerTrack := wNumCurrentSectorsPerTrack; //硬盘wSectorsPerTrack参数
end;
end;
function GetCPUID : TCPUID; assembler; register;
asm
PUSH EBX {Save affected register}
PUSH EDI
MOV EDI,EAX {@Resukt}
MOV EAX,1
DW $A20F {CPUID Command}
STOSD {CPUID[1]}
MOV EAX,EBX
STOSD {CPUID[2]}
MOV EAX,ECX
STOSD {CPUID[3]}
MOV EAX,EDX
STOSD {CPUID[4]}
POP EDI {Restore registers}
POP EBX
end;
function GetCPUVendor : TVendor; assembler; register;
asm
PUSH EBX {Save affected register}
PUSH EDI
MOV EDI,EAX {@Result (TVendor)}
MOV EAX,0
DW $A20F {CPUID Command}
MOV EAX,EBX
XCHG EBX,ECX {save ECX result}
MOV ECX,4
@1:
STOSB
SHR EAX,8
LOOP @1
MOV EAX,EDX
MOV ECX,4
@2:
STOSB
SHR EAX,8
LOOP @2
MOV EAX,EBX
MOV ECX,4
@3:
STOSB
SHR EAX,8
LOOP @3
POP EDI {Restore registers}
POP EBX
end;
function GetCPUIDStr: String;
var
CPUID : TCPUID;
I : Integer;
S : TVendor;
begin
Result := '';
for I := Low(CPUID) to High(CPUID) do CPUID[I] := $FFFFFFFF;
CPUID := GetCPUID;
Result := Result + IntToHex(CPUID[1],8);
Result := Result + IntToHex(CPUID[2],8);
Result := Result + IntToHex(CPUID[3],8);
Result := Result + IntToHex(CPUID[4],8);
S := GetCPUVendor;
Result := Result + S;
end;
Function GetMyID:String;
Var SerialNumber,ModelNumber,FirmwareRev: string;
begin
GetIdeDiskSerialNumber(SerialNumber, ModelNumber,FirmwareRev);
Result:=Trim(SerialNumber)+'-'+Trim(ModelNumber)+'-'+Trim(FirmwareRev)+'-'+GetCPUIDStr;
end;
procedure ConvertStrToList(mS,LapStr:String; lst:TStrings);
Var N,i:Integer;
begin
N:=ItemsOfStr(mS,LapStr);
lst.Clear;
for i:=1 to N do
//if TextOfIndex(mS,LapStr,i)<>'' then
lst.Add(TextOfIndex(mS,LapStr,i));
end;
Function ConvertListToStr(LapStr:String; lst:TStrings):String;
Var i:Integer;
begin
Result:='';
for i:=0 to lst.Count-1 do
//if lst.Strings[i]<>'' then
Result:=Result+lst.Strings[i]+LapStr;
end;
procedure roundRectangle3D(l,t,r,b,dx,dy,nDepth:Integer;aCanvas:TCanvas;cl,clBack:TColor; bFilled:Boolean);
Var i:Integer;
begin
aCanvas.Pen.Width :=2;
aCanvas.Brush.Color:=clBack;
if bFilled then aCanvas.Brush.Style:=bsSolid
else aCanvas.Brush.Style:=bsClear;
for i:=0 to nDepth do
begin
aCanvas.Pen.Color :=PartColor(cl, 1+(nDepth-i)*0.1);
aCanvas.RoundRect(l+i,t+i,r-i,b-i,dx,dy);
if i<nDepth then Continue;
aCanvas.RoundRect(l+i,t+i,r-i,b-i,dx,dy);
end;
end;
procedure MyroundRectangle3D(l,t,r,b,dx,dy,nDepth:Integer;aCanvas:TCanvas;
cl:TColor; bDown:Boolean);
Var i:Integer;
begin
aCanvas.Pen.Width :=1;
aCanvas.Brush.Style:=bsClear;
for i:=0 to nDepth do
begin
if bDown then aCanvas.Pen.Color :=PartColor(cl, 1+i*0.15)
else aCanvas.Pen.Color :=PartColor(cl, 1+(nDepth-i)*0.15);
aCanvas.RoundRect(l+i,t+i,r-i,b-i,dx,dy);
if i<nDepth then Continue;
aCanvas.RoundRect(l+i,t+i,r-i,b-i,dx,dy);
end;
end;
//==微秒级延时==//
procedure DelayUs(nUs:Integer; frq:Int64);
Var c,x,d:Int64;
begin
QueryPerformanceCounter(c);
//hardware not supports a high-resolution performance counter
if c=0 then Exit;
d:=nUs*frq div 1000000; //nUs所需的记数次数
while True do
begin
QueryPerformanceCounter(x);
if (x-c)>=d then Break;
Application.ProcessMessages;
end;
end;
//--------- 微秒延时 ----------------//
procedure MyDelayUs(nUs:Integer);
begin
DelayUs(nUs,cFrq);
end;
//--------- 毫秒延时 ----------------//
procedure MyDelayms(nMs:Integer);
begin
DelayUs(nMs*1000,cFrq);
end;
Function MakeXORString(s:String; cXOR:Byte):String;
Var i:Integer; x:Byte; //===加密字符串
begin
Result:=Inttohex(cXOR,2);
x:=cXOR;
for i:=1 to length(s) do
begin
x:=Ord(s[i]) XOR X;
Result:=Result+inttohex(X ,2);
end;
end;
Function ReturnXORString(sHex:String):String;
Var i:Integer; x:Byte; s:String; //===解密字符串
begin
Result:='';
x:=Strtointdef('$'+sHex[1]+sHex[2],0); //==首先得到Seed==//
for i:=2 to length(sHex) div 2 do
begin
s:=sHex[2*i-1]+sHex[2*i];
x:=Strtointdef('$'+s,0) XOR X;
Result:=Result+Char(x);
x:=Strtointdef('$'+s,0);
end;
end;
Function MyReadColor(aIniFile,Sct,Cnt:String):TColor;
Var r,g,b:Integer;
begin
r:=Strtointdef(ReadOnePara(aIniFile,Sct,Cnt+'R'),255);
g:=Strtointdef(ReadOnePara(aIniFile,Sct,Cnt+'G'),255);
b:=Strtointdef(ReadOnePara(aIniFile,Sct,Cnt+'B'),255);
Result:=RGB(r,g,b);
end;
procedure MyWriteColor(aIniFile,Sct,Cnt:String;Cl:TColor);
begin
WriteOnePara(aIniFile,Sct,Cnt+'R', inttostr(GetRValue(cl)));
WriteOnePara(aIniFile,Sct,Cnt+'G', inttostr(GetGValue(cl)));
WriteOnePara(aIniFile,Sct,Cnt+'B', inttostr(GetBValue(cl)));
end;
procedure MyReadFont(aIniFile, Sct,Cnt:String; sFont:TFont);
begin
sFont.Name:=ReadOnePara(aIniFile,Sct,Cnt+'Name');
if sFont.Name='' then sFont.Name:='宋体';
sFont.Size:=strtointdef(ReadOnePara(aIniFile,Sct,Cnt+'Size'),16);
sFont.color:=MyReadColor(aIniFile,Sct,Cnt);
end;
procedure MyWriteFont(aIniFile,Sct,Cnt:String;fFont:TFont);
begin
WriteOnePara(aIniFile,Sct,Cnt+'Name',fFont.Name);
WriteOnePara(aIniFile,Sct,Cnt+'Size',inttostr(fFont.Size));
MyWriteColor(aIniFile,Sct,Cnt,fFont.Color);
end;
procedure LoadGridTitle(sg: TStringGrid; clb: TCheckListBox);
Var i:Integer;
begin
clb.Items.Clear;
for i:=0 to sg.ColCount-1 do
clb.Items.Add(sg.Cells[i,0]);
end;
//---------在画布的矩形区显示文字,自动调节文字大小---------//
Procedure MyTextOutH(ss:String; //显示文字
align:Integer; //对齐方式
aCanvas:TCanvas; //画布
aRect:TRect; //显示区域
bShowRect:Boolean); //显示矩形边框
Var tW,tH,rW,rH,fSize:Integer;
s:String;
begin
if ss='' then s:=' '
else s:=ss;
fSize:=aCanvas.Font.Size;
rW:=aRect.Right -aRect.Left-2; //矩形区宽
rH:=aRect.Bottom -aRect.Top-2; //矩形区高
tW:=aCanvas.TextWidth(s); //文字宽度
tH:=aCanvas.TextHeight(s); //文字高度
//------先调整高度---------//
if tH>rH then
while True do
begin
aCanvas.Font.Size :=aCanvas.Font.Size-1;
tH:=aCanvas.TextHeight(s); //文字新高度
if tH<=rH then break;
if aCanvas.Font.Size<3 then break;
end;
tW:=aCanvas.TextWidth(s); //文字宽度
tH:=aCanvas.TextHeight(s); //文字高度
//------在调整宽度---------//
if tW>rW then
while True do
begin
aCanvas.Font.Size :=aCanvas.Font.Size-1;
tW:=aCanvas.TextWidth(s); //文字新高度
if tW<=rW then break;
if aCanvas.Font.Size<3 then break;
end;
tW:=aCanvas.TextWidth(s); //文字宽度
tH:=aCanvas.TextHeight(s); //文字高度
aCanvas.Brush.Style:=bsClear;
setbkmode(aCanvas.Handle,TRANSPARENT);
if align=0 then //左对齐
aCanvas.TextOut(aRect.Left+1,aRect.top+1+(rH-tH) div 2,s)
else if align=1 then //中间对齐
aCanvas.TextOut(aRect.Left+(rW-tW) div 2,aRect.top+1+(rH-tH) div 2,s)
else
aCanvas.TextOut(aRect.Left+rW-tW, aRect.top+1+(rH-tH) div 2,s);
if bShowRect then // aCanvas.Rectangle(aRect);
MyRectangle(aCanvas,aRect);
aCanvas.Font.Size:=fSize;
end;
procedure MyRectangle(aCanvas:TCanvas;aRect:TRect);
begin
with aCanvas do
begin
MoveTo(aRect.Left,aRect.Top);
LineTo(aRect.right,aRect.top);
LineTo(aRect.right,aRect.Bottom);
LineTo(aRect.Left,aRect.Bottom);
LineTo(aRect.Left,aRect.Top);
end;
end;
//=====从机器码产生注册码,pCode:产品代号=====//
Function MakeCode(JQM: String; pCode:Byte):String;
Var n:Integer; c:Char;
begin
Result:='';
RandSeed:=19660116 XOR pCode;
n:=0;
while true do
begin
c:=JQM[1+Random(length(JQM))];
if (c='-') OR (c='0') Or (c='O') Or (c=' ') OR (c='1') OR (c='l')then Continue;
Result:=Result+C;
if length(Result)=19 then Break;
end;
Result[5]:='-';
Result[10]:='-';
Result[15]:='-';
end;
procedure DeleteOneRegistryValue(_RootKey: HKEY;
_Localkey,sValue: String);
Var TR: TRegIniFile;
begin
TR := TRegIniFile.Create('');
try
case _RootKey of //default is RootKey=HKEY_CURRENT_USER
HKEY_CLASSES_ROOT,
HKEY_CURRENT_USER,
HKEY_LOCAL_MACHINE,
HKEY_USERS,
HKEY_PERFORMANCE_DATA,
HKEY_CURRENT_CONFIG,
HKEY_DYN_DATA : TR.RootKey := _RootKey;
end; //end case _RootKey
with TRegistry(TR) do
begin
if OpenKey(_Localkey,true) then
try
TR.DeleteValue(sValue);
finally
CloseKey;
end;
end; //with TRegistry(TR)
finally
TR.Free;
end; //try finally
end;
procedure AddOneRegistryValue(_RootKey: HKEY;
_Localkey,sName,sValue: String);
Var TR: TRegIniFile;
begin
TR := TRegIniFile.Create('');
try
case _RootKey of //default is RootKey=HKEY_CURRENT_USER
HKEY_CLASSES_ROOT,
HKEY_CURRENT_USER,
HKEY_LOCAL_MACHINE,
HKEY_USERS,
HKEY_PERFORMANCE_DATA,
HKEY_CURRENT_CONFIG,
HKEY_DYN_DATA : TR.RootKey := _RootKey;
end; //end case _RootKey
with TRegistry(TR) do
begin
if OpenKey(_Localkey,true) then
try
WriteString(sName,sValue);
finally
CloseKey;
end;
end; //with TRegistry(TR)
finally
TR.Free;
end; //try finally
end;
Function RegistryValueExist(_RootKey: HKEY;
_Localkey,sName,sValue: String):Boolean;
Var TR: TRegIniFile; sRead:String;
begin
TR := TRegIniFile.Create('');
sRead:='';
try
case _RootKey of //default is RootKey=HKEY_CURRENT_USER
HKEY_CLASSES_ROOT,
HKEY_CURRENT_USER,
HKEY_LOCAL_MACHINE,
HKEY_USERS,
HKEY_PERFORMANCE_DATA,
HKEY_CURRENT_CONFIG,
HKEY_DYN_DATA : TR.RootKey := _RootKey;
end; //end case _RootKey
with TRegistry(TR) do
begin
if OpenKey(_Localkey,true) then
try
sRead:=ReadString(sName);
finally
CloseKey;
end;
end;
finally
TR.Free;
end;
if sRead=sValue then Result:=True
else Result:=False;
end;
Procedure MyCopyFile(sFile,dFile:string);
var
fs:array[0..512] of char;
begin
try
strPcopy(fs,dFile);
FileSetAttr(fs,0);
CopyFile(PANSIchar(sFile),PAnsiChar(dFile),FALSE);
finally
end;
end;
Function TimeToSecond(t:TTime):Integer;
Var s:Integer;
begin
s:=TimeStrToSecond(timetostr(t),':');
Result:=s;
end;
procedure StringToFont(sFont: string; Font: TFont; bIncludeColor: Boolean = True);
var
P : Integer;
sStyle: string;
begin
with Font do
try
// get font name
P := Pos(',', sFont);
name := Copy(sFont, 2, P - 3);
Delete(sFont, 1, P);
// get font size
P := Pos(',', sFont);
Size := StrToInt(Copy(sFont, 2, P - 2));
Delete(sFont, 1, P);
// get font style
P := Pos(',', sFont);
sStyle := '|' + Copy(sFont, 3, P - 4);
Delete(sFont, 1, P);
// get font color
if bIncludeColor then
Color := StringToColor(Copy(sFont, 3, Length(sFont) - 3));
// convert str font style to
// font style
Style := [];
if (Pos(csfsBold, sStyle) > 0) then
Style := Style + [fsBold];
if (Pos(csfsItalic, sStyle) > 0) then
Style := Style + [fsItalic];
if (Pos(csfsUnderline, sStyle) > 0) then
Style := Style + [fsUnderline];
if (Pos(csfsStrikeout, sStyle) > 0) then
Style := Style + [fsStrikeOut];
except
end;
end;
//
// Output format:
// "Aril", 9, [Bold|Italic], [clAqua]
//
function FontToString(Font: TFont; bIncludeColor: Boolean = True): string;
var
sStyle: string;
begin
with Font do
begin
// convert font style to string
sStyle := '';
if (fsBold in Style) then
sStyle := sStyle + csfsBold;
if (fsItalic in Style) then
sStyle := sStyle + csfsItalic;
if (fsUnderline in Style) then
sStyle := sStyle + csfsUnderline;
if (fsStrikeOut in Style) then
sStyle := sStyle + csfsStrikeout;
if Pos('|',sStyle)=1 then
sStyle :=Copy(sStyle, 2, Length(sStyle) - 1);
Result := Format('"%s", %d, [%s]',[name, Size, sStyle]);
if bIncludeColor then
Result := Result + Format(', [%s]',[ColorToString(Color)]);
end;
end;
Function ReadOneParaDefault(sIniFile,Sct,Idt,sDefault:String):String;
Var aIniFile:TIniFile;
begin
Result:=sDefault;
aIniFile:=TIniFile.Create(sIniFile);
try
if aINiFile.ValueExists(Sct,Idt) then
Result:=aIniFile.ReadString(Sct,Idt,'');
finally
aIniFile.Free;
end;
end;
Function MyReadColorDef(aIniFile,Sct,Cnt:String; clDefault:TColor):TColor;
Var r,g,b:Integer;
begin
r:=Strtoint(ReadOneParadefault(aIniFile,Sct,Cnt+'R',inttostr(GetRValue(clDefault))));
g:=Strtoint(ReadOneParadefault(aIniFile,Sct,Cnt+'G',inttostr(GetGValue(clDefault))));
b:=Strtoint(ReadOneParadefault(aIniFile,Sct,Cnt+'B',inttostr(GetBValue(clDefault))));
Result:=RGB(r,g,b);
end;
initialization
// EVODINI:=UpperCase(ChangeFileExt(Application.ExeName,'.INI'));
if not QueryPerformanceFrequency(cFrq) then
ShowMessage('对不起,发现该计算机没有高性能计数器.'+#13+#10+
'请升级您的计算机和操作系统.系统退出');
end.
浙公网安备 33010602011771号