Delphi 常用函数记录
作者：互联网
原文链接：http://www.cnblogs.com/kernelj/archive/2010/01/26/1656802.html
代码
//判断是否是数字
function IsNumeric(sDestStr: string): Boolean;
//简写多余汉字
function SimplifyWord(sWord: string; iMaxLen: Integer): string;
//读写取注册表中的字符串值
function ReadRegStr(sDWName, KeyName: string; SvrBZ: TSvrOrClient; DefaultValue: string = ''): string;
procedure WriteRegStr(sDWName, KeyName, KeyValue: string; SvrBZ: TSvrOrClient;const isExpand : boolean = false);
//取本机机器名
function GetComputerName: string;
//显示消息框
procedure InfMsg(const hHandle: HWND; const sMsg: string);
procedure ClmMsg(const hHandle: HWND; const sMsg: string);
procedure ErrMsg(const hHandle: HWND; const sMsg: string);
function ConfirmMsg(const hHandle: HWND; const sMsg: string): Boolean;
//检查驱动器类型是否是CDROM
function CheckCDRom(sPath: string): Boolean;
//检查驱动器是否存在
function CheckDriver(sPath: string): Boolean;
//获得windows临时目录
function GetWinTempDir: string;
//取系统目录
function GetSystemDir: string;
//等待执行Winexe
function WinExecAndWait32(Path: PChar; Visibility: Word; Timeout: DWORD): integer;
//在所有子目录中查找文件
function SearchFiles(DirName: string; //启始目录
Files: TStrings; //输出字符串列表
FileName: string = '*.*'; //文件名
Attr: Integer = faAnyFile; //文件属性
FullFileName: Boolean = True; //是否返回完整的文件名
IncludeNormalFiles: Boolean = True; //是否包括Normal属性的文件
IncludeSubDir: Boolean = True): Boolean; //是否在下级目录中查找
//查找所有子目录
function SearchDirs(DirName: string;
Dirs: TStrings;
FullFileName: Boolean = True; //是否返回完整的文件名
IncludeSubDir: Boolean = True): Boolean; //是否在下级目录中查找
//删除所有文件夹和文件
procedure DeleteTree(sDir: string);
//删除文件的只读属性
procedure DelReadOnlyAttr(sFileName: string);
//注册
function Reg32(const sFilename: string): Integer;
//获得桌面路径
function GetDeskTopDir: string;
//获得程序文件夹路径
function GetProgramFilesDir: string;
//获得操作系统版本 [0 windows98] [1 windowsNT] [2 Windows2000]
function GetOSVersion: Integer;
//创建快捷方式
function CreateLink(aPathObj, aPathLink, aDesc: string; iIcon: Integer): Boolean;
//文件操作，拷贝，移动，删除
procedure FileOperator(Apphandle: HWND; Op: integer; Source, Dest: string);
//取动态连接库版本
procedure GetFileVersion(FileName: string; var Major1, Major2, Minor1, Minor2: Word);
//安装新组件包
function NewPack(const PackName, uID, pID: string): Boolean;
//删除组件包
function RemovePack(const PackName: string): boolean;
//注册组件。返回结果 0--成功；1--创建新包出错
function Install_Component(const PackName, DllFile, uID, pID: string): integer;
//删除指定名字的组件，名字是在组件服务中看到的组件的名字
function Remove_Component(const IIobject: string): Boolean;
//关闭组件
function ShutdownPack(const PackName: string): Boolean;
//检测组件是否存在
function PackExists(const IIobject: string): Boolean;
const
RegpathClient = '\SoftWare\Your Path\Client';
RegpathServer = '\SoftWare\Your Path\Server\';
CntStr: string = 'Provider=SQLOLEDB.1;Password=%s;Persist Security Info=True;User ID=%s;Initial Catalog=%s;Data Source=%s';
CrDBStr: string = 'CREATE DATABASE %s'
+ #13 + 'ON'
+ #13 + '(NAME = ''%s'','
+ #13 + 'FILENAME = ''%s%s.mdf'','
+ #13 + 'SIZE = 1,'
+ #13 + 'FILEGROWTH = 10%%)'
+ #13 + 'LOG ON'
+ #13 + '(NAME = ''%s'','
+ #13 + 'FILENAME = ''%s%s.ldf'','
+ #13 + 'SIZE = 1,'
+ #13 + 'FILEGROWTH = 10%%)';
LocalTestSQL: string = 'SELECT * FROM Table';
CWTestSQL: string = 'SELECT * FROM Table';
CXTestSQL: string = 'SELECT * FROM Table';
implementation
function IsNumeric(sDestStr: string): Boolean;
begin
Result := True;
try
StrToFloat(sDestStr);
except
Result := False;
end;
end;
function SimplifyWord(sWord: string; iMaxLen: Integer): string;
var iCount: Integer;
begin
if Length(sWord) > iMaxLen then
begin
Result := Copy(sWord, 1, iMaxLen - 2) + '..'
end else
begin
for iCount := 1 to (iMaxLen - Length(sWord)) do
sWord := ' ' + sWord;
Result := sWord;
end;
end;
function ReadRegStr(sDWName, KeyName: string; SvrBZ: TSvrOrClient; DefaultValue: string = ''): string;
var sRegPath: string;
begin
Result := DefaultValue;
if SvrBZ = scClient then
sRegPath := RegpathClient
else
if SvrBZ = scServer then
sRegPath := RegpathServer + sDWName
else
if SvrBZ = scNone then
sRegPath := sDWName;
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
OpenKey(sRegpath, False);
try
Result := ReadString(KeyName);
except
end;
finally
Free;
end;
end;
procedure WriteRegStr(sDWName, KeyName, KeyValue: string; SvrBZ: TSvrOrClient;const isExpand : boolean = false);
var sRegPath: string;
begin
if SvrBZ = scClient then
sRegPath := RegpathClient
else
if SvrBZ = scServer then
sRegPath := RegpathServer + sDWName
else
if SvrBZ = scNone then
sRegPath := sDWName;
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
OpenKey(sRegpath, True);
if isExpand then
WriteExpandString(KeyName, KeyValue)
else
WriteString(KeyName, KeyValue);
finally
Free;
end;
end;
function GetComputerName: string;
var
PComputeName: array[0..MAX_COMPUTERNAME_LENGTH] of Char;
Length: DWord;
begin
Length := SizeOf(PComputeName);
if Windows.GetComputerName(PComputeName, Length) then
Result := StrPas(PComputeName)
else
Result := '';
end;
procedure InfMsg(const hHandle: HWND; const sMsg: string);
var szMsg, szTitle: array[0..1023] of Char;
begin
MessageBox(hHandle, StrPCopy(szMsg, sMsg),
StrPCopy(szTitle, '系统信息'), MB_OK or MB_ICONINFORMATION); //MB_ICONEXCLAMATION
end;
procedure ClmMsg(const hHandle: HWND; const sMsg: string);
var szMsg, szTitle: array[0..1023] of Char;
begin
MessageBox(hHandle, StrPCopy(szMsg, sMsg),
StrPCopy(szTitle, '系统信息'), MB_OK or MB_ICONEXCLAMATION); //MB_ICONEXCLAMATION
end;
procedure ErrMsg(const hHandle: HWND; const sMsg: string);
var szMsg, szTitle: array[0..1023] of Char;
begin
MessageBox(hHandle, StrPCopy(szMsg, sMsg),
StrPCopy(szTitle, '系统信息'), MB_OK or MB_ICONERROR); //MB_ICONEXCLAMATION
end;
function ConfirmMsg(const hHandle: HWND; const sMsg: string): Boolean;
var szMsg, szTitle: array[0..1023] of Char;
begin
StrPCopy(szMsg, sMsg);
StrPCopy(szTitle, '系统信息');
Result := MessageBox(hHandle, szMsg, szTitle, MB_YESNO or MB_ICONQUESTION or MB_DEFBUTTON2) = IDYES;
end;
function CheckCDRom(sPath: string): Boolean;
var sTempWord: string;
DriveType: TDriveType;
begin
Result := False;
if sPath = '' then Exit;
sTempWord := Copy(sPath, 1, 1);
DriveType := TDriveType(GetDriveType(PChar(sTempWord + ':\')));
if DriveType = dtCDROM then Result := True
end;
function CheckDriver(sPath: string): Boolean;
var sTempWord: string;
DriveType: TDriveType;
begin
Result := False;
if sPath = '' then Exit;
Result := True;
sTempWord := Copy(sPath, 1, 1);
DriveType := TDriveType(GetDriveType(PChar(sTempWord + ':\')));
if (DriveType = dtUnknown) or (DriveType = dtNoDrive) then Result := False;
end;
function GetWinTempDir: string;
var
Path: array[0..Max_Path] of Char;
ResultLength: Integer;
begin
ResultLength := GetTempPath(SizeOf(Path), Path);
if (ResultLength <= Max_Path) and (ResultLength > 0) then
Result := StrPas(Path)
else
Result := 'C:\';
end;
function GetSystemDir: string;
var
Path: array[0..Max_Path] of Char;
ResultLength: Integer;
begin
ResultLength := GetSystemDirectory(Path, SizeOf(Path));
if (ResultLength <= Max_Path) and (ResultLength > 0) then
Result := StrPas(Path)
else
Result := 'C:\';
end;
function WinExecAndWait32(Path: PChar; Visibility: Word;
Timeout: DWORD): integer;
var
WaitResult: integer;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
begin
FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
with StartupInfo do
begin
cb := SizeOf(TStartupInfo);
dwFlags := STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
{ you could pass sw_show or sw_hide as parameter: }
wShowWindow := visibility;
end;
if CreateProcess(nil, path, nil, nil, False,
NORMAL_PRIORITY_CLASS, nil, nil,
StartupInfo, ProcessInfo) then
begin
if TimeOut = 0 then
WaitResult := WaitForSingleObject(ProcessInfo.hProcess, infinite)
else
WaitResult := WaitForSingleObject(ProcessInfo.hProcess, TimeOut);
{ timeout is in miliseconds or INFINITE if you want to wait forever }
Result := WaitResult;
end
else
{ error occurs during CreateProcess see help for details }
Result := GetLastError;
end;
function SearchFiles(DirName: string;
Files: TStrings;
FileName: string = '*.*';
Attr: Integer = faAnyFile;
FullFileName: Boolean = True;
IncludeNormalFiles: Boolean = True;
IncludeSubDir: Boolean = True): Boolean;
procedure AddToResult(FileName: TFileName);
begin
if FullFileName then
Files.Add(DirName + FileName)
else
Files.Add(FileName);
end;
var
SearchRec: TSearchRec;
begin
DirName := IncludeTrailingBackslash(DirName);
Result := FindFirst(DirName + FileName, Attr, SearchRec) = 0;
if Result then
repeat
//去掉 '.' 和 '..'
if (SearchRec.Name = '.') or
(SearchRec.Name = '..') then
Continue;
//如果包括普通文件
if IncludeNormalFiles then
//添加到查找结果中
AddToResult(SearchRec.Name)
else
//检查文件属性与指定属性是否相符
if (SearchRec.Attr and Attr) <> 0 then
//添加到查找结果中
AddToResult(SearchRec.Name);
//如果是子目录，在子目录中查找
if IncludeSubDir then
if (SearchRec.Attr and faDirectory) <> 0 then
SearchFiles(DirName + SearchRec.Name,
Files, FileName, Attr,
FullFileName,
IncludeNormalFiles,
IncludeSubDir);
until FindNext(SearchRec) <> 0;
FindClose(SearchRec);
end;
//查找所有子目录
function SearchDirs(DirName: string;
Dirs: TStrings;
FullFileName: Boolean = True;
IncludeSubDir: Boolean = True): Boolean;
begin
Result := SearchFiles(DirName, Dirs, '*.*', faDirectory, FullFileName, False, IncludeSubDir);
end;
procedure DeleteTree(sDir: string);
var
sr: TSearchRec;
begin
if sDir = '' then Exit;
{$I-}
try
if FindFirst(sDir + '\*.*', faAnyFile, sr) = 0 then
begin
if not ((sr.Name = '.') or (sr.Name = '..')) then
begin
try
DelReadOnlyAttr(sDir + '\' + sr.Name);
DeleteFile(PChar(sDir + '\' + sr.Name));
except
end;
end;
while FindNext(sr) = 0 do
begin
if not ((sr.Name = '.') or (sr.Name = '..') or (sr.Attr = faDirectory)) then
begin
DelReadOnlyAttr(sDir + '\' + sr.Name);
DeleteFile(PChar(sDir + '\' + sr.Name));
end;
if (sr.Attr = faDirectory) and (sr.Name <> '.') and (sr.Name <> '..') then
try
DeleteTree(sDir + '\' + sr.Name);
except
end;
end;
Sysutils.FindClose(sr);
RmDir(sDir);
end;
except
end;
end;
procedure DelReadOnlyAttr(sFileName: string);
var Attrs: Integer;
begin
if not FileExists(sFileName) then Exit;
Attrs := FileGetAttr(sFileName);
if Attrs and faReadOnly <> 0 then
FileSetAttr(sFileName, Attrs - faReadOnly);
end;
function Reg32(const sFilename: string): Integer;
var res: integer;
exe_str: string;
begin
exe_str := 'regsvr32.exe /s "' + sFilename + '"';
res := WinExec(pchar(exe_str), SW_HIDE);
case res of
0: Result := 1; // out of memory;
ERROR_BAD_FORMAT: Result := 2; //The .EXE file is invalid (non-Win32 .EXE or error in .EXE image).
ERROR_FILE_NOT_FOUND: Result := 3; //The specified file was not found.
ERROR_PATH_NOT_FOUND: Result := 4; //The specified path was not found
else
Result := 0;
end;
end;
function GetDeskTopDir: string;
var PIDL: PItemIDList;
Path: array[0..MAX_PATH] of Char;
begin
SHGetSpecialFolderLocation(0, CSIDL_DESKTOPDIRECTORY, PIDL);
SHGetPathFromIDList(PIDL, Path);
Result := Path;
end;
function GetProgramFilesDir: string;
var PIDL: PItemIDList;
Path: array[0..MAX_PATH] of Char;
begin
SHGetSpecialFolderLocation(0, CSIDL_PROGRAMS, PIDL);
SHGetPathFromIDList(PIDL, Path);
Result := Path;
end;
function GetOSVersion: Integer;
var
OSVer: TOSVERSIONINFO;
begin
OSVer.dwOSVersionInfoSize := Sizeof(TOSVERSIONINFO);
GetVersionEx(OSVer);
if OSVer.dwPlatformId = 1 then
Result := 0
else if (OSVer.dwPlatformId = 2) and (OSVer.dwMajorVersion = 4) then
Result := 1
else if (OSVer.dwPlatformId = 2) and (OSVer.dwMajorVersion = 5) then
Result := 2
else Result := -1;
end;
function CreateLink(aPathObj, aPathLink, aDesc: string; iIcon: Integer): Boolean;
const
IID_IPersistFile: TGUID = (D1: $0000010B; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46));
var sLink: IShellLink;
PersFile: IPersistFile;
begin
Result := false;
if SUCCEEDED(CoCreateInstance(CLSID_ShellLink, nil,
CLSCTX_INPROC_SERVER, IID_IShellLinkA, sLink)) then
begin
sLink.SetPath(PChar(aPathObj));
sLink.SetWorkingDirectory(pChar(ExtractFilePath(aPathObj)));
sLink.SetDescription(PChar(aDesc));
if iIcon >= 0 then sLink.SetIconLocation(PChar(aPathObj), iIcon);
if SUCCEEDED(sLink.QueryInterface(IID_IPersistFile, PersFile)) then
begin
PersFile.Save(StringToOLEStr(aPathLink), TRUE);
Result := true;
end;
end;
end;
procedure FileOperator(Apphandle: HWND; Op: integer; Source, Dest: string);
var
FileOperator: TSHFileOpStruct;
CharSetFrom, CharSetTo: array[0..1023] of char;
begin
FileOperator.Wnd := Apphandle;
FileOperator.wFunc := Op;
FileOperator.fFlags := FileOperator.fFlags + FOF_NOCONFIRMATION;
FillChar(CharSetFrom, SizeOf(CharSetFrom), #0);
CopyMemory(@CharSetFrom[0], @Source[1], Length(Source));
FileOperator.pFrom := @CharSetFrom[0];
FillChar(CharSetTo, SizeOf(CharSetTo), #0);
CopyMemory(@CharSetTo[0], @Dest[1], Length(Dest));
FileOperator.pTo := @CharSetTo[0];
SHFileOperation(FileOperator);
end;
procedure GetFileVersion(FileName: string; var Major1, Major2, Minor1, Minor2: Word);
var
Info: Pointer;
InfoSize: DWORD;
FileInfo: PVSFixedFileInfo;
FileInfoSize: DWORD;
Tmp: DWORD;
begin
InfoSize := GetFileVersionInfoSize(PChar(FileName), Tmp);
Major1 := 0; Major2 := 0; Minor1 := 0; Minor2 := 0;
if InfoSize = 0 then
//file doesnt have version info/exist
else
begin
GetMem(Info, InfoSize);
try
GetFileVersionInfo(PChar(FileName), 0, InfoSize, Info);
VerQueryValue(Info, '\', Pointer(FileInfo), FileInfoSize);
Major1 := FileInfo.dwFileVersionMS shr 16;
Major2 := FileInfo.dwFileVersionMS and $FFFF;
Minor1 := FileInfo.dwFileVersionLS shr 16;
Minor2 := FileInfo.dwFileVersionLS and $FFFF;
finally
FreeMem(Info, FileInfoSize);
end;
end;
end;
function PackExists(const IIobject: string): Boolean;
var
MTS_catalog: MTSAdmin_TLB.ICatalog;
MTS_catalogpack, MTS_componentsInPack: MTSAdmin_TLB.ICatalogCollection;
MTS_catalogobject, MTS_catalogcomponent: MTSAdmin_TLB.ICatalogObject;
COM_catalog: COMAdmin_TLB.ICOMAdminCatalog;
COM_catalogpack, COM_componentsInPack: COMAdmin_TLB.ICatalogCollection;
COM_catalogobject, COM_catalogcomponent: COMAdmin_TLB.ICatalogObject;
ww, qq: integer;
begin
result := false;
try
case GetOSVersion of
1: begin
MTS_catalog := MTSAdmin_TLB.CoCatalog.Create;
MTS_catalogpack := MTS_catalog.GetCollection('Packages') as MTSAdmin_TLB.ICatalogCollection;
MTS_catalogpack.Populate;
for ww := 0 to MTS_catalogpack.Count - 1 do
begin
MTS_catalogobject := MTS_catalogpack.Get_Item(ww) as MTSAdmin_TLB.ICatalogObject;
MTS_componentsInPack := MTS_catalogpack.GetCollection('ComponentsInPackage', MTS_catalogobject.Key) as MTSAdmin_TLB.ICatalogCollection;
try
MTS_componentsInPack.Populate;
for qq := 0 to MTS_componentsInPack.Count - 1 do
begin
MTS_catalogcomponent := (MTS_componentsInPack.item[qq] as MTSAdmin_TLB.ICatalogObject);
if uppercase(MTS_catalogcomponent.name) = uppercase(IIObject) then
begin
MTS_componentsInPack.Remove(qq);
MTS_componentsInPack.SaveChanges;
result := True; break;
end;
end;
except
continue;
end;
if result then break;
end;
end;
2: begin
COM_catalog := COMAdmin_TLB.CoCOMAdminCatalog.Create;
COM_catalogpack := COM_catalog.GetCollection('Applications') as COMAdmin_TLB.ICatalogCollection;
COM_catalogpack.Populate;
for ww := 0 to COM_catalogpack.Count - 1 do
begin
COM_catalogobject := COM_catalogpack.Get_Item(ww) as COMAdmin_TLB.ICatalogObject;
COM_componentsInPack := COM_catalogpack.GetCollection('Components', COM_catalogobject.Key) as COMAdmin_TLB.ICatalogCollection;
try
COM_componentsInPack.Populate;
for qq := 0 to COM_componentsInPack.Count - 1 do
begin
COM_catalogcomponent := (COM_componentsInPack.item[qq] as COMAdmin_TLB.ICatalogObject);
if uppercase(COM_catalogcomponent.name) = uppercase(IIObject) then
begin
result := True; break;
end;
end;
except
continue;
end;
if result then break;
end;
end;
end;
finally
COM_catalogobject := nil;
COM_catalogpack := nil;
COM_catalog := nil;
MTS_catalogobject := nil;
MTS_catalogpack := nil;
MTS_catalog := nil;
end;
end;
function NewPack(const PackName, uID, pID: string): Boolean;
var
MTS_catalog: MTSAdmin_TLB.ICatalog;
MTS_catalogpack: MTSAdmin_TLB.ICatalogCollection;
MTS_catalogobject: MTSAdmin_TLB.ICatalogObject;
COM_catalog: COMAdmin_TLB.ICOMAdminCatalog;
COM_catalogpack: COMAdmin_TLB.ICatalogCollection;
COM_catalogobject: COMAdmin_TLB.ICatalogObject;
ww: integer;
Pack_Name: string;
Pack_Existed: Boolean;
begin
Pack_Existed := False;
Pack_Name := Trim(uppercase(PackName));
try
Result := False;
case GetOSVersion of
1: begin // winnt
MTS_catalog := MTSAdmin_TLB.CoCatalog.Create;
MTS_catalogpack := MTS_catalog.GetCollection('Packages') as MTSAdmin_TLB.ICatalogCollection;
MTS_catalogpack.Populate;
for ww := 0 to MTS_catalogpack.Count - 1 do
begin
MTS_catalogobject := MTS_catalogpack.Get_Item(ww) as MTSAdmin_TLB.ICatalogObject;
if uppercase(MTS_catalogobject.Value['Name']) = Pack_Name then
begin
Pack_Existed := True;
//MTS_catalogobject.Value['Activation'] := 'Local';
MTS_catalogpack.SaveChanges;
//MTS_catalogobject.Value['Identity'] := uID;
//MTS_catalogobject.Value['Password'] := pID;
MTS_catalogpack.SaveChanges;
Break;
end;
end;
if not Pack_Existed then
begin
MTS_catalogobject := MTS_catalogpack.Add as MTSAdmin_TLB.ICatalogObject;
MTS_catalogobject.Value['Name'] := PackName;
//MTS_catalogobject.Value['Identity'] := uID;
//MTS_catalogobject.Value['Password'] := pID;
//MTS_catalogobject.Value['Activation'] := 'Local';
MTS_catalogpack.SaveChanges;
end;
end;
2: begin //win2000
COM_catalog := COMAdmin_TLB.CoCOMAdminCatalog.Create;
COM_catalogpack := COM_catalog.GetCollection('Applications') as COMAdmin_TLB.ICatalogCollection;
COM_catalogpack.Populate;
for ww := 0 to COM_catalogpack.Count - 1 do
begin
COM_catalogobject := COM_catalogpack.Get_Item(ww) as COMAdmin_TLB.ICatalogObject;
if uppercase(COM_catalogobject.Value['Name']) = Pack_Name then
begin
Pack_Existed := True;
//COM_catalogobject.Value['Activation'] := 'Local';
//COM_catalogpack.SaveChanges;
//COM_catalogobject.Value['Identity'] := uID;
//COM_catalogobject.Value['Password'] := pID;
COM_catalogpack.SaveChanges;
Break;
end;
end;
if not Pack_Existed then
begin
COM_catalogobject := COM_catalogpack.Add as COMAdmin_TLB.ICatalogObject;
COM_catalogobject.Value['Name'] := PackName;
//COM_catalogobject.Value['Identity'] := uID;
//COM_catalogobject.Value['Password'] := pID;
//COM_catalogobject.Value['Activation'] := 'Local';
COM_catalogpack.SaveChanges;
end;
end;
end;
Result := True;
finally
COM_catalogobject := nil;
COM_catalogpack := nil;
COM_catalog := nil;
MTS_catalogobject := nil;
MTS_catalogpack := nil;
MTS_catalog := nil;
end;
end;
function RemovePack(const PackName: string): boolean;
var
MTS_catalog: MTSAdmin_TLB.ICatalog;
MTS_catalogpack: MTSAdmin_TLB.ICatalogCollection;
MTS_catalogobject: MTSAdmin_TLB.ICatalogObject;
COM_catalog: COMAdmin_TLB.ICOMAdminCatalog;
COM_catalogpack: COMAdmin_TLB.ICatalogCollection;
COM_catalogobject: COMAdmin_TLB.ICatalogObject;
ww: integer;
Pack_Name: string;
begin
Pack_Name := Trim(uppercase(PackName));
try
Result := false;
case GetOSVersion of
1: begin //winnt
MTS_catalog := MTSAdmin_TLB.CoCatalog.Create;
MTS_catalogpack := MTS_catalog.GetCollection('Packages') as MTSAdmin_TLB.ICatalogCollection;
MTS_catalogpack.Populate;
for ww := 0 to MTS_catalogpack.Count - 1 do
begin
MTS_catalogobject := MTS_catalogpack.Get_Item(ww) as MTSAdmin_TLB.ICatalogObject;
if uppercase(MTS_catalogobject.Value['Name']) = Pack_Name then
begin
MTS_catalogpack.Remove(ww);
MTS_catalogpack.SaveChanges;
Break;
end;
end;
end;
2: begin //win2000
COM_catalog := COMAdmin_TLB.CoCOMAdminCatalog.Create;
COM_catalogpack := COM_catalog.GetCollection('Applications') as COMAdmin_TLB.ICatalogCollection;
COM_catalogpack.Populate;
for ww := 0 to COM_catalogpack.Count - 1 do
begin
COM_catalogobject := COM_catalogpack.Get_Item(ww) as COMAdmin_TLB.ICatalogObject;
if uppercase(COM_catalogobject.Value['Name']) = Pack_Name then
begin
COM_catalogpack.Remove(ww);
COM_catalogpack.SaveChanges;
Break;
end;
end;
end;
end;
Result := True;
finally
COM_catalogobject := nil;
COM_catalogpack := nil;
COM_catalog := nil;
MTS_catalogobject := nil;
MTS_catalogpack := nil;
MTS_catalog := nil;
end;
end;
function Install_Component(const PackName, DllFile, uID, pID: string): integer;
var
ww: integer;
keyy: OleVariant;
MTS_catalog: MTSAdmin_TLB.ICatalog;
MTS_catalogpack, MTS_componentsInPack: MTSAdmin_TLB.ICatalogCollection;
MTS_catalogobject: MTSAdmin_TLB.ICatalogObject;
MTS_util: MTSAdmin_TLB.IComponentUtil;
COM_catalog: COMAdmin_TLB.ICOMAdminCatalog;
begin
result := 0;
if NewPack(PackName, uID, pID) then
try
case GetOSVersion of
1: begin
MTS_catalog := MTSAdmin_TLB.CoCatalog.Create;
MTS_catalogpack := MTS_catalog.GetCollection('Packages') as MTSAdmin_TLB.ICatalogCollection;
MTS_catalogpack.Populate;
for ww := 0 to MTS_catalogpack.Count - 1 do
begin
MTS_catalogobject := MTS_catalogpack.Get_Item(ww) as MTSAdmin_TLB.ICatalogObject;
if uppercase(MTS_catalogobject.Value['Name']) = uppercase(PackName) then
begin
keyy := MTS_catalogobject.Key;
Break;
end;
end;
MTS_componentsInPack := MTS_catalogpack.GetCollection('ComponentsInPackage', keyy) as MTSAdmin_TLB.ICatalogCollection;
MTS_util := MTS_componentsInPack.GetUtilInterface as MTSAdmin_TLB.IComponentUtil;
try
MTS_util.InstallComponent(DllFile, '', '');
except
Result := 1;
end;
end;
2: begin
COM_catalog := COMAdmin_TLB.CoCOMAdminCatalog.Create;
try
COM_catalog.InstallComponent(PackName, DllFile, '', '');
except
Result := 1;
end;
end;
end;
finally
MTS_catalogobject := nil;
MTS_catalogpack := nil;
MTS_catalog := nil;
MTS_componentsInPack := nil;
MTS_util := nil;
COM_catalog := nil;
end;
end;
function Remove_Component(const IIobject: string): Boolean;
var
MTS_catalog: MTSAdmin_TLB.ICatalog;
MTS_catalogpack, MTS_componentsInPack: MTSAdmin_TLB.ICatalogCollection;
MTS_catalogobject, MTS_catalogcomponent: MTSAdmin_TLB.ICatalogObject;
COM_catalog: COMAdmin_TLB.ICOMAdminCatalog;
COM_catalogpack, COM_componentsInPack: COMAdmin_TLB.ICatalogCollection;
COM_catalogobject, COM_catalogcomponent: COMAdmin_TLB.ICatalogObject;
ww, qq: integer;
begin
result := false;
try
case GetOSVersion of
1: begin
MTS_catalog := MTSAdmin_TLB.CoCatalog.Create;
MTS_catalogpack := MTS_catalog.GetCollection('Packages') as MTSAdmin_TLB.ICatalogCollection;
MTS_catalogpack.Populate;
for ww := 0 to MTS_catalogpack.Count - 1 do
begin
MTS_catalogobject := MTS_catalogpack.Get_Item(ww) as MTSAdmin_TLB.ICatalogObject;
MTS_componentsInPack := MTS_catalogpack.GetCollection('ComponentsInPackage', MTS_catalogobject.Key) as MTSAdmin_TLB.ICatalogCollection;
try
MTS_componentsInPack.Populate;
for qq := 0 to MTS_componentsInPack.Count - 1 do
begin
MTS_catalogcomponent := (MTS_componentsInPack.item[qq] as MTSAdmin_TLB.ICatalogObject);
if uppercase(MTS_catalogcomponent.name) = uppercase(IIObject) then
begin
MTS_componentsInPack.Remove(qq);
MTS_componentsInPack.SaveChanges;
result := True;
break;
end;
end;
except
continue;
end;
if result then break;
end;
end;
2: begin
COM_catalog := COMAdmin_TLB.CoCOMAdminCatalog.Create;
COM_catalogpack := COM_catalog.GetCollection('Applications') as COMAdmin_TLB.ICatalogCollection;
COM_catalogpack.Populate;
for ww := 0 to COM_catalogpack.Count - 1 do
begin
COM_catalogobject := COM_catalogpack.Get_Item(ww) as COMAdmin_TLB.ICatalogObject;
COM_componentsInPack := COM_catalogpack.GetCollection('Components', COM_catalogobject.Key) as COMAdmin_TLB.ICatalogCollection;
try
COM_componentsInPack.Populate;
for qq := 0 to COM_componentsInPack.Count - 1 do
begin
COM_catalogcomponent := (COM_componentsInPack.item[qq] as COMAdmin_TLB.ICatalogObject);
if uppercase(COM_catalogcomponent.name) = uppercase(IIObject) then
begin
COM_componentsInPack.Remove(qq);
COM_componentsInPack.SaveChanges;
result := True;
break;
end;
end;
except
continue;
end;
if result then break;
end;
end;
end;
Result := True;
finally
COM_catalogobject := nil;
COM_catalogpack := nil;
COM_catalog := nil;
MTS_catalogobject := nil;
MTS_catalogpack := nil;
MTS_catalog := nil;
end;
end;
function ShutdownPack(const PackName: string): Boolean;
var
ww: integer;
MTS_catalog: MTSAdmin_TLB.ICatalog;
MTS_catalogpack: MTSAdmin_TLB.ICatalogCollection;
MTS_catalogobject: MTSAdmin_TLB.ICatalogObject;
MTS_PackageUtil: MTSAdmin_TLB.IPackageUtil;
COM_catalog: COMAdmin_TLB.ICOMAdminCatalog;
begin
Result := False;
try
case GetOSVersion of
1: begin
// IPackageUtil.ShutdownPackage 的参数是 ID 不是 NAME ,所以要通过 NAME 找到 ID
MTS_catalog := MTSAdmin_TLB.CoCatalog.Create;
MTS_catalogpack := MTS_catalog.GetCollection('Packages') as MTSAdmin_TLB.ICatalogCollection;
MTS_catalogpack.Populate;
ww := 0;
while ww < MTS_catalogpack.Count do
begin
MTS_catalogobject := MTS_catalogpack.Get_Item(ww) as MTSAdmin_TLB.ICatalogObject;
if uppercase(MTS_catalogobject.Value['Name']) = uppercase(PackName) then break;
inc(ww);
end;
if ww < MTS_catalogpack.Count then
begin
MTS_PackageUtil := MTS_catalogpack.GetUtilInterface as MTSAdmin_TLB.IPackageUtil;
MTS_PackageUtil.ShutdownPackage(MTS_catalogobject.Value['ID']);
sleep(5000);
Result := True;
end;
end;
2: begin
COM_catalog := COMAdmin_TLB.CoCOMAdminCatalog.Create;
try
COM_catalog.ShutdownApplication(PackName);
Result := True;
except
Result := False;
end;
end;
end;
finally
COM_catalog := nil;
MTS_catalog := nil;
MTS_catalogpack := nil;
MTS_PackageUtil := nil;
end;
end;
记录一下经常用到方法
代码
//判断是否是数字function IsNumeric(sDestStr: string): Boolean;
//简写多余汉字
function SimplifyWord(sWord: string; iMaxLen: Integer): string;
//读写取注册表中的字符串值
function ReadRegStr(sDWName, KeyName: string; SvrBZ: TSvrOrClient; DefaultValue: string = ''): string;
procedure WriteRegStr(sDWName, KeyName, KeyValue: string; SvrBZ: TSvrOrClient;const isExpand : boolean = false);
//取本机机器名
function GetComputerName: string;
//显示消息框
procedure InfMsg(const hHandle: HWND; const sMsg: string);
procedure ClmMsg(const hHandle: HWND; const sMsg: string);
procedure ErrMsg(const hHandle: HWND; const sMsg: string);
function ConfirmMsg(const hHandle: HWND; const sMsg: string): Boolean;
//检查驱动器类型是否是CDROM
function CheckCDRom(sPath: string): Boolean;
//检查驱动器是否存在
function CheckDriver(sPath: string): Boolean;
//获得windows临时目录
function GetWinTempDir: string;
//取系统目录
function GetSystemDir: string;
//等待执行Winexe
function WinExecAndWait32(Path: PChar; Visibility: Word; Timeout: DWORD): integer;
//在所有子目录中查找文件
function SearchFiles(DirName: string; //启始目录
Files: TStrings; //输出字符串列表
FileName: string = '*.*'; //文件名
Attr: Integer = faAnyFile; //文件属性
FullFileName: Boolean = True; //是否返回完整的文件名
IncludeNormalFiles: Boolean = True; //是否包括Normal属性的文件
IncludeSubDir: Boolean = True): Boolean; //是否在下级目录中查找
//查找所有子目录
function SearchDirs(DirName: string;
Dirs: TStrings;
FullFileName: Boolean = True; //是否返回完整的文件名
IncludeSubDir: Boolean = True): Boolean; //是否在下级目录中查找
//删除所有文件夹和文件
procedure DeleteTree(sDir: string);
//删除文件的只读属性
procedure DelReadOnlyAttr(sFileName: string);
//注册
function Reg32(const sFilename: string): Integer;
//获得桌面路径
function GetDeskTopDir: string;
//获得程序文件夹路径
function GetProgramFilesDir: string;
//获得操作系统版本 [0 windows98] [1 windowsNT] [2 Windows2000]
function GetOSVersion: Integer;
//创建快捷方式
function CreateLink(aPathObj, aPathLink, aDesc: string; iIcon: Integer): Boolean;
//文件操作，拷贝，移动，删除
procedure FileOperator(Apphandle: HWND; Op: integer; Source, Dest: string);
//取动态连接库版本
procedure GetFileVersion(FileName: string; var Major1, Major2, Minor1, Minor2: Word);
//安装新组件包
function NewPack(const PackName, uID, pID: string): Boolean;
//删除组件包
function RemovePack(const PackName: string): boolean;
//注册组件。返回结果 0--成功；1--创建新包出错
function Install_Component(const PackName, DllFile, uID, pID: string): integer;
//删除指定名字的组件，名字是在组件服务中看到的组件的名字
function Remove_Component(const IIobject: string): Boolean;
//关闭组件
function ShutdownPack(const PackName: string): Boolean;
//检测组件是否存在
function PackExists(const IIobject: string): Boolean;
const
RegpathClient = '\SoftWare\Your Path\Client';
RegpathServer = '\SoftWare\Your Path\Server\';
CntStr: string = 'Provider=SQLOLEDB.1;Password=%s;Persist Security Info=True;User ID=%s;Initial Catalog=%s;Data Source=%s';
CrDBStr: string = 'CREATE DATABASE %s'
+ #13 + 'ON'
+ #13 + '(NAME = ''%s'','
+ #13 + 'FILENAME = ''%s%s.mdf'','
+ #13 + 'SIZE = 1,'
+ #13 + 'FILEGROWTH = 10%%)'
+ #13 + 'LOG ON'
+ #13 + '(NAME = ''%s'','
+ #13 + 'FILENAME = ''%s%s.ldf'','
+ #13 + 'SIZE = 1,'
+ #13 + 'FILEGROWTH = 10%%)';
LocalTestSQL: string = 'SELECT * FROM Table';
CWTestSQL: string = 'SELECT * FROM Table';
CXTestSQL: string = 'SELECT * FROM Table';
implementation
function IsNumeric(sDestStr: string): Boolean;
begin
Result := True;
try
StrToFloat(sDestStr);
except
Result := False;
end;
end;
function SimplifyWord(sWord: string; iMaxLen: Integer): string;
var iCount: Integer;
begin
if Length(sWord) > iMaxLen then
begin
Result := Copy(sWord, 1, iMaxLen - 2) + '..'
end else
begin
for iCount := 1 to (iMaxLen - Length(sWord)) do
sWord := ' ' + sWord;
Result := sWord;
end;
end;
function ReadRegStr(sDWName, KeyName: string; SvrBZ: TSvrOrClient; DefaultValue: string = ''): string;
var sRegPath: string;
begin
Result := DefaultValue;
if SvrBZ = scClient then
sRegPath := RegpathClient
else
if SvrBZ = scServer then
sRegPath := RegpathServer + sDWName
else
if SvrBZ = scNone then
sRegPath := sDWName;
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
OpenKey(sRegpath, False);
try
Result := ReadString(KeyName);
except
end;
finally
Free;
end;
end;
procedure WriteRegStr(sDWName, KeyName, KeyValue: string; SvrBZ: TSvrOrClient;const isExpand : boolean = false);
var sRegPath: string;
begin
if SvrBZ = scClient then
sRegPath := RegpathClient
else
if SvrBZ = scServer then
sRegPath := RegpathServer + sDWName
else
if SvrBZ = scNone then
sRegPath := sDWName;
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
OpenKey(sRegpath, True);
if isExpand then
WriteExpandString(KeyName, KeyValue)
else
WriteString(KeyName, KeyValue);
finally
Free;
end;
end;
function GetComputerName: string;
var
PComputeName: array[0..MAX_COMPUTERNAME_LENGTH] of Char;
Length: DWord;
begin
Length := SizeOf(PComputeName);
if Windows.GetComputerName(PComputeName, Length) then
Result := StrPas(PComputeName)
else
Result := '';
end;
procedure InfMsg(const hHandle: HWND; const sMsg: string);
var szMsg, szTitle: array[0..1023] of Char;
begin
MessageBox(hHandle, StrPCopy(szMsg, sMsg),
StrPCopy(szTitle, '系统信息'), MB_OK or MB_ICONINFORMATION); //MB_ICONEXCLAMATION
end;
procedure ClmMsg(const hHandle: HWND; const sMsg: string);
var szMsg, szTitle: array[0..1023] of Char;
begin
MessageBox(hHandle, StrPCopy(szMsg, sMsg),
StrPCopy(szTitle, '系统信息'), MB_OK or MB_ICONEXCLAMATION); //MB_ICONEXCLAMATION
end;
procedure ErrMsg(const hHandle: HWND; const sMsg: string);
var szMsg, szTitle: array[0..1023] of Char;
begin
MessageBox(hHandle, StrPCopy(szMsg, sMsg),
StrPCopy(szTitle, '系统信息'), MB_OK or MB_ICONERROR); //MB_ICONEXCLAMATION
end;
function ConfirmMsg(const hHandle: HWND; const sMsg: string): Boolean;
var szMsg, szTitle: array[0..1023] of Char;
begin
StrPCopy(szMsg, sMsg);
StrPCopy(szTitle, '系统信息');
Result := MessageBox(hHandle, szMsg, szTitle, MB_YESNO or MB_ICONQUESTION or MB_DEFBUTTON2) = IDYES;
end;
function CheckCDRom(sPath: string): Boolean;
var sTempWord: string;
DriveType: TDriveType;
begin
Result := False;
if sPath = '' then Exit;
sTempWord := Copy(sPath, 1, 1);
DriveType := TDriveType(GetDriveType(PChar(sTempWord + ':\')));
if DriveType = dtCDROM then Result := True
end;
function CheckDriver(sPath: string): Boolean;
var sTempWord: string;
DriveType: TDriveType;
begin
Result := False;
if sPath = '' then Exit;
Result := True;
sTempWord := Copy(sPath, 1, 1);
DriveType := TDriveType(GetDriveType(PChar(sTempWord + ':\')));
if (DriveType = dtUnknown) or (DriveType = dtNoDrive) then Result := False;
end;
function GetWinTempDir: string;
var
Path: array[0..Max_Path] of Char;
ResultLength: Integer;
begin
ResultLength := GetTempPath(SizeOf(Path), Path);
if (ResultLength <= Max_Path) and (ResultLength > 0) then
Result := StrPas(Path)
else
Result := 'C:\';
end;
function GetSystemDir: string;
var
Path: array[0..Max_Path] of Char;
ResultLength: Integer;
begin
ResultLength := GetSystemDirectory(Path, SizeOf(Path));
if (ResultLength <= Max_Path) and (ResultLength > 0) then
Result := StrPas(Path)
else
Result := 'C:\';
end;
function WinExecAndWait32(Path: PChar; Visibility: Word;
Timeout: DWORD): integer;
var
WaitResult: integer;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
begin
FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
with StartupInfo do
begin
cb := SizeOf(TStartupInfo);
dwFlags := STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
{ you could pass sw_show or sw_hide as parameter: }
wShowWindow := visibility;
end;
if CreateProcess(nil, path, nil, nil, False,
NORMAL_PRIORITY_CLASS, nil, nil,
StartupInfo, ProcessInfo) then
begin
if TimeOut = 0 then
WaitResult := WaitForSingleObject(ProcessInfo.hProcess, infinite)
else
WaitResult := WaitForSingleObject(ProcessInfo.hProcess, TimeOut);
{ timeout is in miliseconds or INFINITE if you want to wait forever }
Result := WaitResult;
end
else
{ error occurs during CreateProcess see help for details }
Result := GetLastError;
end;
function SearchFiles(DirName: string;
Files: TStrings;
FileName: string = '*.*';
Attr: Integer = faAnyFile;
FullFileName: Boolean = True;
IncludeNormalFiles: Boolean = True;
IncludeSubDir: Boolean = True): Boolean;
procedure AddToResult(FileName: TFileName);
begin
if FullFileName then
Files.Add(DirName + FileName)
else
Files.Add(FileName);
end;
var
SearchRec: TSearchRec;
begin
DirName := IncludeTrailingBackslash(DirName);
Result := FindFirst(DirName + FileName, Attr, SearchRec) = 0;
if Result then
repeat
//去掉 '.' 和 '..'
if (SearchRec.Name = '.') or
(SearchRec.Name = '..') then
Continue;
//如果包括普通文件
if IncludeNormalFiles then
//添加到查找结果中
AddToResult(SearchRec.Name)
else
//检查文件属性与指定属性是否相符
if (SearchRec.Attr and Attr) <> 0 then
//添加到查找结果中
AddToResult(SearchRec.Name);
//如果是子目录，在子目录中查找
if IncludeSubDir then
if (SearchRec.Attr and faDirectory) <> 0 then
SearchFiles(DirName + SearchRec.Name,
Files, FileName, Attr,
FullFileName,
IncludeNormalFiles,
IncludeSubDir);
until FindNext(SearchRec) <> 0;
FindClose(SearchRec);
end;
//查找所有子目录
function SearchDirs(DirName: string;
Dirs: TStrings;
FullFileName: Boolean = True;
IncludeSubDir: Boolean = True): Boolean;
begin
Result := SearchFiles(DirName, Dirs, '*.*', faDirectory, FullFileName, False, IncludeSubDir);
end;
procedure DeleteTree(sDir: string);
var
sr: TSearchRec;
begin
if sDir = '' then Exit;
{$I-}
try
if FindFirst(sDir + '\*.*', faAnyFile, sr) = 0 then
begin
if not ((sr.Name = '.') or (sr.Name = '..')) then
begin
try
DelReadOnlyAttr(sDir + '\' + sr.Name);
DeleteFile(PChar(sDir + '\' + sr.Name));
except
end;
end;
while FindNext(sr) = 0 do
begin
if not ((sr.Name = '.') or (sr.Name = '..') or (sr.Attr = faDirectory)) then
begin
DelReadOnlyAttr(sDir + '\' + sr.Name);
DeleteFile(PChar(sDir + '\' + sr.Name));
end;
if (sr.Attr = faDirectory) and (sr.Name <> '.') and (sr.Name <> '..') then
try
DeleteTree(sDir + '\' + sr.Name);
except
end;
end;
Sysutils.FindClose(sr);
RmDir(sDir);
end;
except
end;
end;
procedure DelReadOnlyAttr(sFileName: string);
var Attrs: Integer;
begin
if not FileExists(sFileName) then Exit;
Attrs := FileGetAttr(sFileName);
if Attrs and faReadOnly <> 0 then
FileSetAttr(sFileName, Attrs - faReadOnly);
end;
function Reg32(const sFilename: string): Integer;
var res: integer;
exe_str: string;
begin
exe_str := 'regsvr32.exe /s "' + sFilename + '"';
res := WinExec(pchar(exe_str), SW_HIDE);
case res of
0: Result := 1; // out of memory;
ERROR_BAD_FORMAT: Result := 2; //The .EXE file is invalid (non-Win32 .EXE or error in .EXE image).
ERROR_FILE_NOT_FOUND: Result := 3; //The specified file was not found.
ERROR_PATH_NOT_FOUND: Result := 4; //The specified path was not found
else
Result := 0;
end;
end;
function GetDeskTopDir: string;
var PIDL: PItemIDList;
Path: array[0..MAX_PATH] of Char;
begin
SHGetSpecialFolderLocation(0, CSIDL_DESKTOPDIRECTORY, PIDL);
SHGetPathFromIDList(PIDL, Path);
Result := Path;
end;
function GetProgramFilesDir: string;
var PIDL: PItemIDList;
Path: array[0..MAX_PATH] of Char;
begin
SHGetSpecialFolderLocation(0, CSIDL_PROGRAMS, PIDL);
SHGetPathFromIDList(PIDL, Path);
Result := Path;
end;
function GetOSVersion: Integer;
var
OSVer: TOSVERSIONINFO;
begin
OSVer.dwOSVersionInfoSize := Sizeof(TOSVERSIONINFO);
GetVersionEx(OSVer);
if OSVer.dwPlatformId = 1 then
Result := 0
else if (OSVer.dwPlatformId = 2) and (OSVer.dwMajorVersion = 4) then
Result := 1
else if (OSVer.dwPlatformId = 2) and (OSVer.dwMajorVersion = 5) then
Result := 2
else Result := -1;
end;
function CreateLink(aPathObj, aPathLink, aDesc: string; iIcon: Integer): Boolean;
const
IID_IPersistFile: TGUID = (D1: $0000010B; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46));
var sLink: IShellLink;
PersFile: IPersistFile;
begin
Result := false;
if SUCCEEDED(CoCreateInstance(CLSID_ShellLink, nil,
CLSCTX_INPROC_SERVER, IID_IShellLinkA, sLink)) then
begin
sLink.SetPath(PChar(aPathObj));
sLink.SetWorkingDirectory(pChar(ExtractFilePath(aPathObj)));
sLink.SetDescription(PChar(aDesc));
if iIcon >= 0 then sLink.SetIconLocation(PChar(aPathObj), iIcon);
if SUCCEEDED(sLink.QueryInterface(IID_IPersistFile, PersFile)) then
begin
PersFile.Save(StringToOLEStr(aPathLink), TRUE);
Result := true;
end;
end;
end;
procedure FileOperator(Apphandle: HWND; Op: integer; Source, Dest: string);
var
FileOperator: TSHFileOpStruct;
CharSetFrom, CharSetTo: array[0..1023] of char;
begin
FileOperator.Wnd := Apphandle;
FileOperator.wFunc := Op;
FileOperator.fFlags := FileOperator.fFlags + FOF_NOCONFIRMATION;
FillChar(CharSetFrom, SizeOf(CharSetFrom), #0);
CopyMemory(@CharSetFrom[0], @Source[1], Length(Source));
FileOperator.pFrom := @CharSetFrom[0];
FillChar(CharSetTo, SizeOf(CharSetTo), #0);
CopyMemory(@CharSetTo[0], @Dest[1], Length(Dest));
FileOperator.pTo := @CharSetTo[0];
SHFileOperation(FileOperator);
end;
procedure GetFileVersion(FileName: string; var Major1, Major2, Minor1, Minor2: Word);
var
Info: Pointer;
InfoSize: DWORD;
FileInfo: PVSFixedFileInfo;
FileInfoSize: DWORD;
Tmp: DWORD;
begin
InfoSize := GetFileVersionInfoSize(PChar(FileName), Tmp);
Major1 := 0; Major2 := 0; Minor1 := 0; Minor2 := 0;
if InfoSize = 0 then
//file doesnt have version info/exist
else
begin
GetMem(Info, InfoSize);
try
GetFileVersionInfo(PChar(FileName), 0, InfoSize, Info);
VerQueryValue(Info, '\', Pointer(FileInfo), FileInfoSize);
Major1 := FileInfo.dwFileVersionMS shr 16;
Major2 := FileInfo.dwFileVersionMS and $FFFF;
Minor1 := FileInfo.dwFileVersionLS shr 16;
Minor2 := FileInfo.dwFileVersionLS and $FFFF;
finally
FreeMem(Info, FileInfoSize);
end;
end;
end;
function PackExists(const IIobject: string): Boolean;
var
MTS_catalog: MTSAdmin_TLB.ICatalog;
MTS_catalogpack, MTS_componentsInPack: MTSAdmin_TLB.ICatalogCollection;
MTS_catalogobject, MTS_catalogcomponent: MTSAdmin_TLB.ICatalogObject;
COM_catalog: COMAdmin_TLB.ICOMAdminCatalog;
COM_catalogpack, COM_componentsInPack: COMAdmin_TLB.ICatalogCollection;
COM_catalogobject, COM_catalogcomponent: COMAdmin_TLB.ICatalogObject;
ww, qq: integer;
begin
result := false;
try
case GetOSVersion of
1: begin
MTS_catalog := MTSAdmin_TLB.CoCatalog.Create;
MTS_catalogpack := MTS_catalog.GetCollection('Packages') as MTSAdmin_TLB.ICatalogCollection;
MTS_catalogpack.Populate;
for ww := 0 to MTS_catalogpack.Count - 1 do
begin
MTS_catalogobject := MTS_catalogpack.Get_Item(ww) as MTSAdmin_TLB.ICatalogObject;
MTS_componentsInPack := MTS_catalogpack.GetCollection('ComponentsInPackage', MTS_catalogobject.Key) as MTSAdmin_TLB.ICatalogCollection;
try
MTS_componentsInPack.Populate;
for qq := 0 to MTS_componentsInPack.Count - 1 do
begin
MTS_catalogcomponent := (MTS_componentsInPack.item[qq] as MTSAdmin_TLB.ICatalogObject);
if uppercase(MTS_catalogcomponent.name) = uppercase(IIObject) then
begin
MTS_componentsInPack.Remove(qq);
MTS_componentsInPack.SaveChanges;
result := True; break;
end;
end;
except
continue;
end;
if result then break;
end;
end;
2: begin
COM_catalog := COMAdmin_TLB.CoCOMAdminCatalog.Create;
COM_catalogpack := COM_catalog.GetCollection('Applications') as COMAdmin_TLB.ICatalogCollection;
COM_catalogpack.Populate;
for ww := 0 to COM_catalogpack.Count - 1 do
begin
COM_catalogobject := COM_catalogpack.Get_Item(ww) as COMAdmin_TLB.ICatalogObject;
COM_componentsInPack := COM_catalogpack.GetCollection('Components', COM_catalogobject.Key) as COMAdmin_TLB.ICatalogCollection;
try
COM_componentsInPack.Populate;
for qq := 0 to COM_componentsInPack.Count - 1 do
begin
COM_catalogcomponent := (COM_componentsInPack.item[qq] as COMAdmin_TLB.ICatalogObject);
if uppercase(COM_catalogcomponent.name) = uppercase(IIObject) then
begin
result := True; break;
end;
end;
except
continue;
end;
if result then break;
end;
end;
end;
finally
COM_catalogobject := nil;
COM_catalogpack := nil;
COM_catalog := nil;
MTS_catalogobject := nil;
MTS_catalogpack := nil;
MTS_catalog := nil;
end;
end;
function NewPack(const PackName, uID, pID: string): Boolean;
var
MTS_catalog: MTSAdmin_TLB.ICatalog;
MTS_catalogpack: MTSAdmin_TLB.ICatalogCollection;
MTS_catalogobject: MTSAdmin_TLB.ICatalogObject;
COM_catalog: COMAdmin_TLB.ICOMAdminCatalog;
COM_catalogpack: COMAdmin_TLB.ICatalogCollection;
COM_catalogobject: COMAdmin_TLB.ICatalogObject;
ww: integer;
Pack_Name: string;
Pack_Existed: Boolean;
begin
Pack_Existed := False;
Pack_Name := Trim(uppercase(PackName));
try
Result := False;
case GetOSVersion of
1: begin // winnt
MTS_catalog := MTSAdmin_TLB.CoCatalog.Create;
MTS_catalogpack := MTS_catalog.GetCollection('Packages') as MTSAdmin_TLB.ICatalogCollection;
MTS_catalogpack.Populate;
for ww := 0 to MTS_catalogpack.Count - 1 do
begin
MTS_catalogobject := MTS_catalogpack.Get_Item(ww) as MTSAdmin_TLB.ICatalogObject;
if uppercase(MTS_catalogobject.Value['Name']) = Pack_Name then
begin
Pack_Existed := True;
//MTS_catalogobject.Value['Activation'] := 'Local';
MTS_catalogpack.SaveChanges;
//MTS_catalogobject.Value['Identity'] := uID;
//MTS_catalogobject.Value['Password'] := pID;
MTS_catalogpack.SaveChanges;
Break;
end;
end;
if not Pack_Existed then
begin
MTS_catalogobject := MTS_catalogpack.Add as MTSAdmin_TLB.ICatalogObject;
MTS_catalogobject.Value['Name'] := PackName;
//MTS_catalogobject.Value['Identity'] := uID;
//MTS_catalogobject.Value['Password'] := pID;
//MTS_catalogobject.Value['Activation'] := 'Local';
MTS_catalogpack.SaveChanges;
end;
end;
2: begin //win2000
COM_catalog := COMAdmin_TLB.CoCOMAdminCatalog.Create;
COM_catalogpack := COM_catalog.GetCollection('Applications') as COMAdmin_TLB.ICatalogCollection;
COM_catalogpack.Populate;
for ww := 0 to COM_catalogpack.Count - 1 do
begin
COM_catalogobject := COM_catalogpack.Get_Item(ww) as COMAdmin_TLB.ICatalogObject;
if uppercase(COM_catalogobject.Value['Name']) = Pack_Name then
begin
Pack_Existed := True;
//COM_catalogobject.Value['Activation'] := 'Local';
//COM_catalogpack.SaveChanges;
//COM_catalogobject.Value['Identity'] := uID;
//COM_catalogobject.Value['Password'] := pID;
COM_catalogpack.SaveChanges;
Break;
end;
end;
if not Pack_Existed then
begin
COM_catalogobject := COM_catalogpack.Add as COMAdmin_TLB.ICatalogObject;
COM_catalogobject.Value['Name'] := PackName;
//COM_catalogobject.Value['Identity'] := uID;
//COM_catalogobject.Value['Password'] := pID;
//COM_catalogobject.Value['Activation'] := 'Local';
COM_catalogpack.SaveChanges;
end;
end;
end;
Result := True;
finally
COM_catalogobject := nil;
COM_catalogpack := nil;
COM_catalog := nil;
MTS_catalogobject := nil;
MTS_catalogpack := nil;
MTS_catalog := nil;
end;
end;
function RemovePack(const PackName: string): boolean;
var
MTS_catalog: MTSAdmin_TLB.ICatalog;
MTS_catalogpack: MTSAdmin_TLB.ICatalogCollection;
MTS_catalogobject: MTSAdmin_TLB.ICatalogObject;
COM_catalog: COMAdmin_TLB.ICOMAdminCatalog;
COM_catalogpack: COMAdmin_TLB.ICatalogCollection;
COM_catalogobject: COMAdmin_TLB.ICatalogObject;
ww: integer;
Pack_Name: string;
begin
Pack_Name := Trim(uppercase(PackName));
try
Result := false;
case GetOSVersion of
1: begin //winnt
MTS_catalog := MTSAdmin_TLB.CoCatalog.Create;
MTS_catalogpack := MTS_catalog.GetCollection('Packages') as MTSAdmin_TLB.ICatalogCollection;
MTS_catalogpack.Populate;
for ww := 0 to MTS_catalogpack.Count - 1 do
begin
MTS_catalogobject := MTS_catalogpack.Get_Item(ww) as MTSAdmin_TLB.ICatalogObject;
if uppercase(MTS_catalogobject.Value['Name']) = Pack_Name then
begin
MTS_catalogpack.Remove(ww);
MTS_catalogpack.SaveChanges;
Break;
end;
end;
end;
2: begin //win2000
COM_catalog := COMAdmin_TLB.CoCOMAdminCatalog.Create;
COM_catalogpack := COM_catalog.GetCollection('Applications') as COMAdmin_TLB.ICatalogCollection;
COM_catalogpack.Populate;
for ww := 0 to COM_catalogpack.Count - 1 do
begin
COM_catalogobject := COM_catalogpack.Get_Item(ww) as COMAdmin_TLB.ICatalogObject;
if uppercase(COM_catalogobject.Value['Name']) = Pack_Name then
begin
COM_catalogpack.Remove(ww);
COM_catalogpack.SaveChanges;
Break;
end;
end;
end;
end;
Result := True;
finally
COM_catalogobject := nil;
COM_catalogpack := nil;
COM_catalog := nil;
MTS_catalogobject := nil;
MTS_catalogpack := nil;
MTS_catalog := nil;
end;
end;
function Install_Component(const PackName, DllFile, uID, pID: string): integer;
var
ww: integer;
keyy: OleVariant;
MTS_catalog: MTSAdmin_TLB.ICatalog;
MTS_catalogpack, MTS_componentsInPack: MTSAdmin_TLB.ICatalogCollection;
MTS_catalogobject: MTSAdmin_TLB.ICatalogObject;
MTS_util: MTSAdmin_TLB.IComponentUtil;
COM_catalog: COMAdmin_TLB.ICOMAdminCatalog;
begin
result := 0;
if NewPack(PackName, uID, pID) then
try
case GetOSVersion of
1: begin
MTS_catalog := MTSAdmin_TLB.CoCatalog.Create;
MTS_catalogpack := MTS_catalog.GetCollection('Packages') as MTSAdmin_TLB.ICatalogCollection;
MTS_catalogpack.Populate;
for ww := 0 to MTS_catalogpack.Count - 1 do
begin
MTS_catalogobject := MTS_catalogpack.Get_Item(ww) as MTSAdmin_TLB.ICatalogObject;
if uppercase(MTS_catalogobject.Value['Name']) = uppercase(PackName) then
begin
keyy := MTS_catalogobject.Key;
Break;
end;
end;
MTS_componentsInPack := MTS_catalogpack.GetCollection('ComponentsInPackage', keyy) as MTSAdmin_TLB.ICatalogCollection;
MTS_util := MTS_componentsInPack.GetUtilInterface as MTSAdmin_TLB.IComponentUtil;
try
MTS_util.InstallComponent(DllFile, '', '');
except
Result := 1;
end;
end;
2: begin
COM_catalog := COMAdmin_TLB.CoCOMAdminCatalog.Create;
try
COM_catalog.InstallComponent(PackName, DllFile, '', '');
except
Result := 1;
end;
end;
end;
finally
MTS_catalogobject := nil;
MTS_catalogpack := nil;
MTS_catalog := nil;
MTS_componentsInPack := nil;
MTS_util := nil;
COM_catalog := nil;
end;
end;
function Remove_Component(const IIobject: string): Boolean;
var
MTS_catalog: MTSAdmin_TLB.ICatalog;
MTS_catalogpack, MTS_componentsInPack: MTSAdmin_TLB.ICatalogCollection;
MTS_catalogobject, MTS_catalogcomponent: MTSAdmin_TLB.ICatalogObject;
COM_catalog: COMAdmin_TLB.ICOMAdminCatalog;
COM_catalogpack, COM_componentsInPack: COMAdmin_TLB.ICatalogCollection;
COM_catalogobject, COM_catalogcomponent: COMAdmin_TLB.ICatalogObject;
ww, qq: integer;
begin
result := false;
try
case GetOSVersion of
1: begin
MTS_catalog := MTSAdmin_TLB.CoCatalog.Create;
MTS_catalogpack := MTS_catalog.GetCollection('Packages') as MTSAdmin_TLB.ICatalogCollection;
MTS_catalogpack.Populate;
for ww := 0 to MTS_catalogpack.Count - 1 do
begin
MTS_catalogobject := MTS_catalogpack.Get_Item(ww) as MTSAdmin_TLB.ICatalogObject;
MTS_componentsInPack := MTS_catalogpack.GetCollection('ComponentsInPackage', MTS_catalogobject.Key) as MTSAdmin_TLB.ICatalogCollection;
try
MTS_componentsInPack.Populate;
for qq := 0 to MTS_componentsInPack.Count - 1 do
begin
MTS_catalogcomponent := (MTS_componentsInPack.item[qq] as MTSAdmin_TLB.ICatalogObject);
if uppercase(MTS_catalogcomponent.name) = uppercase(IIObject) then
begin
MTS_componentsInPack.Remove(qq);
MTS_componentsInPack.SaveChanges;
result := True;
break;
end;
end;
except
continue;
end;
if result then break;
end;
end;
2: begin
COM_catalog := COMAdmin_TLB.CoCOMAdminCatalog.Create;
COM_catalogpack := COM_catalog.GetCollection('Applications') as COMAdmin_TLB.ICatalogCollection;
COM_catalogpack.Populate;
for ww := 0 to COM_catalogpack.Count - 1 do
begin
COM_catalogobject := COM_catalogpack.Get_Item(ww) as COMAdmin_TLB.ICatalogObject;
COM_componentsInPack := COM_catalogpack.GetCollection('Components', COM_catalogobject.Key) as COMAdmin_TLB.ICatalogCollection;
try
COM_componentsInPack.Populate;
for qq := 0 to COM_componentsInPack.Count - 1 do
begin
COM_catalogcomponent := (COM_componentsInPack.item[qq] as COMAdmin_TLB.ICatalogObject);
if uppercase(COM_catalogcomponent.name) = uppercase(IIObject) then
begin
COM_componentsInPack.Remove(qq);
COM_componentsInPack.SaveChanges;
result := True;
break;
end;
end;
except
continue;
end;
if result then break;
end;
end;
end;
Result := True;
finally
COM_catalogobject := nil;
COM_catalogpack := nil;
COM_catalog := nil;
MTS_catalogobject := nil;
MTS_catalogpack := nil;
MTS_catalog := nil;
end;
end;
function ShutdownPack(const PackName: string): Boolean;
var
ww: integer;
MTS_catalog: MTSAdmin_TLB.ICatalog;
MTS_catalogpack: MTSAdmin_TLB.ICatalogCollection;
MTS_catalogobject: MTSAdmin_TLB.ICatalogObject;
MTS_PackageUtil: MTSAdmin_TLB.IPackageUtil;
COM_catalog: COMAdmin_TLB.ICOMAdminCatalog;
begin
Result := False;
try
case GetOSVersion of
1: begin
// IPackageUtil.ShutdownPackage 的参数是 ID 不是 NAME ,所以要通过 NAME 找到 ID
MTS_catalog := MTSAdmin_TLB.CoCatalog.Create;
MTS_catalogpack := MTS_catalog.GetCollection('Packages') as MTSAdmin_TLB.ICatalogCollection;
MTS_catalogpack.Populate;
ww := 0;
while ww < MTS_catalogpack.Count do
begin
MTS_catalogobject := MTS_catalogpack.Get_Item(ww) as MTSAdmin_TLB.ICatalogObject;
if uppercase(MTS_catalogobject.Value['Name']) = uppercase(PackName) then break;
inc(ww);
end;
if ww < MTS_catalogpack.Count then
begin
MTS_PackageUtil := MTS_catalogpack.GetUtilInterface as MTSAdmin_TLB.IPackageUtil;
MTS_PackageUtil.ShutdownPackage(MTS_catalogobject.Value['ID']);
sleep(5000);
Result := True;
end;
end;
2: begin
COM_catalog := COMAdmin_TLB.CoCOMAdminCatalog.Create;
try
COM_catalog.ShutdownApplication(PackName);
Result := True;
except
Result := False;
end;
end;
end;
finally
COM_catalog := nil;
MTS_catalog := nil;
MTS_catalogpack := nil;
MTS_PackageUtil := nil;
end;
end;
转载于:https://www.cnblogs.com/kernelj/archive/2010/01/26/1656802.html
标签：begin,end,函数,记录,MTS,Delphi,TLB,COM,string 来源： https://blog.csdn.net/weixin_30512043/article/details/96618391