📄 publicunit.pas
字号:
unit PublicUnit;
interface
USES Windows, SysUtils,WinTypes, WinProcs, Classes, Graphics,ShellApi,ADODB, Messages,forms,
ComObj, ActiveX,Dialogs,OleCtrls, SHDocVw,ShlObj;
Function GetPath: string;
procedure FindAddress(WebString:String;WebBrowser:TWebBrowser);
Function GetSystemPath:String;
Function GetWinPath:String; //得到windows目录
function DeleteSubStr(S, SubStr: String): String;
FUNCTION ALLTRIM(STR:STRING):STRING;
function TestFloat(s : string): string;
function IntToLZStr(value : integer;digits : byte) : string;
Function ConnectDatabaseAccess(DB:TADOConnection;cFileName,cPswd:String):Boolean;
function CompactDatabase(const AFileName, APassWord: string): Boolean;
function GetWinStr1(PosStr,WinStr,EndStr: String;Start:BOOLEAN): string;
function GetWinStr(PosStr,WinStr: String): boolean;
function PadL(cVal: string; nWide: integer; cChar: char): string;
function encrypt(CodeStr:String):String;//简单家密
function DeCode(codeStr:String):String; //简单解密
function GetSpecialFolderDir(i: Integer):string;
procedure CreateShortCut(SourceFileFullName: string;
DestFileFullName: WideString);
var
IntereConnct:Boolean;
MyTime : TSystemTime;
ShowPass:Boolean;
ShowFrmInt:Integer;
mOK:Boolean;
Pass_OK,REG_OK:Boolean;
implementation
function GetSpecialFolderDir(i: Integer):string;
const
dirName : Array[0..33] of String=
('桌面 ','INTERNET ','程序组 ','控制面板 ',
'打印机 ','我的文档 ','收藏夹 ','启动组 ',
'最近文档 ','发送到 ','回收站 ','开始菜单 ',
'','','','',
'桌面目录 ','我的电脑 ','网络 ','网上邻居目录 ',
'字体 ','模板 ','*开始菜单 ','*程序组 ',
'*启动组 ','*桌面目录 ','应用程序数据 ','PRINTHOOD ',
'ALTSTARTUP ','C_ALTSTARTUP ','C_FAVORITES ','Internet缓冲目录 ',
'COOKIES ','历史记录 ');
var
pidl:pItemIDList;
buffer:array [ 0..255 ] of char ;
// i: Integer;
tmp: String;
begin
Result:='特殊文件夹路径:'+chr(13)+chr(10);
// for i:=0 to 29 do
// begin
SHGetSpecialFolderLocation(Application.Handle , i, pidl);
SHGetPathFromIDList(pidl, buffer); //转换成文件系统的路径
tmp:=StrPas(buffer);
if tmp<>'' then
Result:=Tmp;
// Result:=DirName[i]+ tmp + Chr(13)+chr(10);
// end;
end;
procedure CreateShortCut(SourceFileFullName: string;
DestFileFullName: WideString);
var
MyObject : IUnknown;
MySLink : IShellLink;
MyPFile : IPersistFile;
begin
MyObject := CreateComObject(CLSID_ShellLink);
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;
with MySLink do
begin
SetPath(PChar(SourceFileFullName));
SetWorkingDirectory(PChar(ExtractFilePath(SourceFileFullName)));
end;
MyPFile.Save(PWChar(DestFileFullName), False);
end;
procedure FindAddress(WebString:String;WebBrowser:TWebBrowser);
var
Flags: OLEVariant;
begin
Flags := 0;
WebBrowser.Navigate(WideString(WebString), Flags, Flags, Flags, Flags);
end;
function encrypt(CodeStr:String):String;
var i:integer;
begin
result:=codeStr;
for i:=1 to length(Result) do
result[i]:=Succ(Succ(Result[i]));
end;
function DeCode(CodeStr:String):String;
var i:integer;
begin
result:=CodeStr;
for i:=1 to Length(Result) do
Result[i]:=pred(pred(Result[i]));
end;
function PadL(cVal: string; nWide: integer; cChar: char): string; //填充字符（cChar）
var
i1,nStart: integer;
begin
if length(cVal) < nWide then
begin
nStart:=length(cVal);
for i1:=nStart to nWide-1 do
cVal:=cChar+cVal;
end;
PadL:=cVal;
end;
function padleft(S: String; N: Integer): String; //左边格式化字符串
begin
While Length(S) < N do
Insert(' ',S,1);
Result:=S
end;
function GetWinStr(PosStr,WinStr: String): boolean;
var
s: String;
ETpos: Integer;
begin
GetWinStr:=False;
ETpos:= pos(PosStr, WinStr);
if ETpos > 1 then
begin
// s:= copy(WinStr,ETpos,Length(WinStr));
// GetWinStr:=S;
GetWinStr:=True;
end ;
end;
function GetWinStr1(PosStr,WinStr,EndStr: String;Start:BOOLEAN): string;
var
s: String;
ETpos1: Integer;
ETpos2: Integer;
begin
// GetWinStr:=lse;
ETpos1:= pos(PosStr, WinStr);
ETpos2:= pos(EndStr, WinStr);
GetWinStr1:='';
if (ETpos1 >= 1) and (ETpos2>=ETpos1)then
begin
if Start then
s:= copy(WinStr,ETpos1,(ETPOS2-ETPos1))
else
s:=copy(WinStr,ETpos1+length(posstr),(ETPOS2-ETPos1)-length(posstr));
GetWinStr1:=S;
// GetWinStr:=True;
end ;
end;
function padright(S: String; N: Integer): String; //右边格式化字符串
begin
While Length(S) < N do
Insert(' ',S,Length(S)+1);
Result:=S
end;
//金额小写转大写的子程序
Function XxToDx(const hjnum:real):String;
var Vstr,zzz,cc,cc1,Presult:string;
xxbb:array[1..12]of string;
uppna:array[0..9] of string;
iCount,iZero,vPoint,vdtlno:integer;
begin
//* 设置大写中文数字和相应单位数组 *//
xxbb[1]:=' 亿 ';
xxbb[2]:=' 仟 ';
xxbb[3]:=' 佰 ';
xxbb[4]:=' 拾 ';
xxbb[5]:=' 万 ';
xxbb[6]:=' 仟 ';
xxbb[7]:=' 佰 ';
xxbb[8]:=' 拾 ';
xxbb[9]:=' 元 ';
xxbb[10]:='.';
xxbb[11]:=' 角 ';
xxbb[12]:=' 分 ';
uppna[0]:=' 零 ';
uppna[1]:=' 壹 ';
uppna[2]:=' 贰 ';
uppna[3]:=' 叁 ';
uppna[4]:=' 肆 ';
uppna[5]:=' 伍 ';
uppna[6]:=' 陆 ';
uppna[7]:=' 柒 ';
uppna[8]:=' 捌 ';
uppna[9]:=' 玖 ';
Str(hjnum:12:2,Vstr);
cc:='';
cc1:='';
zzz:='';
result:='';
presult:='';
iZero:=0;
vPoint:=0;
for iCount:=1 to 10 do
begin
cc:=Vstr[iCount];
if cc<>' ' then
begin
zzz:=xxbb[iCount];
if cc='0' then
begin
if iZero<1 then //* 对“零”进行判断 *//
cc:=' 零 '
else
cc:='';
if iCount=5 then //* 对万位“零”的处理 *//
if copy(result,length(result)-1,2)=' 零 ' then
result:=copy(result,1,length(result)-2)+xxbb[iCount]
+' 零 '
else
result:=result+xxbb[iCount];
cc1:=cc;
zzz:='';
iZero:=iZero+1;
end
else
begin
if cc='.' then
begin
cc:='';
if (cc1='') or (cc1=' 零 ') then
begin
Presult:=copy(result,1,Length(result)-2);
result:=Presult;
iZero:=15;
end;
if iZero>=1 then
zzz:=xxbb[9]
else
zzz:='';
vPoint:=1;
end
else
begin
iZero:=0;
cc:=uppna[StrToInt(cc)];
end
end;
result:=result+(cc+zzz)
end;
end;
If Vstr[11]='0' then //* 对小数点后两位进行处理 *//
begin
if Vstr[12]<>'0' then
begin
cc:=' 零 ';
result:=result+cc;
cc:=uppna[StrToInt(Vstr[12])];
result:=result+(uppna[0]+cc+xxbb[12]);
end
end
else
begin
if iZero=15 then
begin
cc:=' 零 ';
result:=result+cc;
end;
cc:=uppna[StrToInt(Vstr[11])];
result:=result+(cc+xxbb[11]);
if Vstr[12]<>'0' then
begin
cc:=uppna[StrToInt(Vstr[12])];
result:=result+(cc+xxbb[12]);
end;
end;
result:=result+' 正 ';
end;
//Memo1.Lines.Add(IHtmlDocument2(WebBrowser1.Document).Body.OuterHtml); //直接显示网页源代码
//,MSHTML
FUNCTION RTOI( RealNum: REAL ): LONGINT;//转换REAL到LONGINT
VAR
s: STRING;
l: LONGINT;
i: INTEGER;
BEGIN
STR( RealNum:17:2,s );
// s :=Left(s, LENGTH(s) - 3);
s:=Copy(s,1,LENGTH(s) - 3);
VAL(s, l, i );
RTOI:=l;
END;
function GetCurrency(number: PChar): string; //把一个数值变成一个本地的金额字符串？
var
tmpStr: string;
begin
SetLength(tmpStr, 255);
GetCurrencyFormat(LOCALE_SYSTEM_DEFAULT, 0, number, nil, PChar(tmpStr), Length(tmpStr));
Result := tmpStr;
end;
function qd0str(const count,num:integer):String;
Var
s1,s2:String;
begin
s1:=IntToStr(Num);
s2:='00000000000000000000';
if (Length(s1)>=count) then
s2:=''
else if(count>20) then
SetLength(S2,20-Length(s1))
else
SetLength(S2,count-Length(s1));
Result:=S2+S1;
end;
function IntToLZStr(value : integer;digits : byte) : string;
var
Res : string;
begin
Res:=IntToStr(value);
while Length(Res)<digits do
Insert('0',res,1);
IntToLZStr:=Res;
end;
Function GetWinPath:String; //得到windows目录
var
MySysPath : PCHAR ;
begin
GetMem(MySysPath,255);
GetWindowsDirectory(MySysPath,255);
Result:=StrPas(MySysPath);
FreeMem(MySysPath,255);
end;
Function GetSystemPath:String; //得到系统目录
var
MySysPath : PCHAR ;
begin
GetMem(MySysPath,255);
GetSystemDirectory(MySysPath,255);
Result:=StrPas(MySysPath);
FreeMem(MySysPath,255);
end;
function SetTime(Year,Month,Day,Hour,Min,Sec:WORD):BOOLEAN ; //更改系统时间
begin
FillChar (MyTime, sizeof(MyTime), #0);
MyTime.wYear := YEAR;
MyTime.wMonth := MONTH;
MyTime.wDay := DAY;
MyTime.wHour:=Hour;
MyTime.wMinute:=Min;
MyTime.wSecond:=Sec;
// fill out more.. important!
if not SetSystemTime (MyTime) then
ShowMessage('更改系统时间错误!');
end;
function CompactDatabase(const AFileName, APassWord: string): Boolean; //压缩ACCESS数据库
const
SConnectionString = 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=%s;'
+ 'Jet OLEDB:Database Password=%s;';
var
SPath: string;
SFile: array[0..254] of Char;
STempFileName: string;
JE: OleVariant;
function GetTempDir: string;
var
Buffer: array[0..MAX_PATH] of Char;
begin
ZeroMemory(@Buffer, MAX_PATH);
GetTempPath(MAX_PATH, Buffer);
Result := IncludeTrailingBackslash(StrPas(Buffer));
end;
begin
Result := False;
SPath := GetTempDir; //取得Windows的Temp路径
GetTempFileName(PChar(SPath), '~ACP', 0, SFile); //取得Temp文件名,Windows将自动建立0字节文件
STempFileName := SFile; //PChar->String
if not DeleteFile(PChar(STempFileName)) then Exit; //删除Windows建立的0字节文件
try
JE := CreateOleObject('JRO.JetEngine'); //建立OLE对象,函数结束OLE对象超过作用域自动释放
OleCheck(JE.CompactDatabase(Format(SConnectionString, [AFileName, APassWord]),
Format(SConnectionString, [STempFileName, APassWord]))); //压缩数据库
//复制并覆盖源数据库文件,如果复制失败则函数返回假,压缩成功但没有到函数的功能
Result := CopyFile(PChar(STempFileName), PChar(AFileName), False);
DeleteFile(PChar(STempFileName)); //删除临时文件
except
//压缩失败
end;
end;
Function ConnectDatabaseAccess(DB:TADOConnection;cFileName,cPswd:String):Boolean; //连接ACCES数据库
var
Str:String;
begin
result := false;
Str:=Format('Provider=Microsoft.Jet.OLEDB.4.0;Data Source=%s;Persist Security Info=False;'
+'Jet OLEDB:Database Password=%s',[cFileName,cPswd]);
DB.Connected:=false;
DB.ConnectionString := Str;
try
DB.Connected:=True;
Result := true;
except
on e:exception do
begin
str := Format('不能连接数据库:'#13'连接串：%s'#13'错误：%s',
[Str,e.Message]);
MessageBox(Application.Handle,PChar(str),
Pchar('提示'), MB_OK or MB_ICONINFORMATION);
exit;
end;
end;
end;
FUNCTION ALLTRIM(STR:STRING):STRING; //去掉字符串的两边空格
VAR
LENG:WORD;
RESU:STRING;
I:WORD;
BEGIN
LENG:=LENGTH(STR);
RESU:=STR;
I:=1;
WHILE (COPY(RESU,LENG-I+1,1)=#$20) AND (I<=LENG) DO
BEGIN
I:=I+1;
END;
RESU:=COPY(RESU,1,LENG-I+1);
LENG:=LENGTH(RESU);
I:=1;
WHILE (COPY(RESU,I,1)=#$20) AND (I<=LENG) DO
BEGIN
I:=I+1;
END;
ALLTRIM:=COPY(RESU,I,LENG-I+1);
END;
function DeleteSubStr(S, SubStr: String): String;
begin
while Pos(SubStr, S) <> 0 do
Delete(S, Pos(SubStr, S), Length(SubStr));
Result := S;
end;
function TestFloat(s : string): string;
var
i : integer;
x : double;
begin
i := System.Pos(',',s);
if i<> 0 then
S := DeleteSubStr(S, ',');
result:=s;
end;
Function GetPath: string;
begin
Result:=ExtractFilePath(ParamStr(0));
end;
end.
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -