Delphi 常用函数记录

//判断是否是数字  
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;