shareunit.pas

三层的通用架构

unit ShareUnit;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls,
  Forms, ExtCtrls, StdCtrls, Registry, Graphics;

const
  Key: array[0..9] of string = (
         '{3DD28C32-19B7-4891-AA44-EF85A411CF2E}',
         '{18CFAF5C-D87D-4987-8BF1-42A020322E0F}',
         '{18D37B10-560A-4D7C-A3CF-DD74EFE380FE}',
         '{B96628E3-4A50-4400-9A06-39D80BD4E090}',
         '{3A8F39A5-5BBE-46E3-BDB7-E74579BC3286}',
         '{02006866-3F32-4D22-9E4B-568B8113363F}',
         '{D84DEC1C-C3DE-4FEA-8554-3A986214A3BD}',
         '{AC72E37E-20A7-48F0-B3AA-C10C82F0D7D2}',
         '{FA0CC0AC-E054-44B1-9ABD-DD67267BC943}',
         '{DAC97CAC-9211-4398-877B-E64451D9E8BB}');
  KeyName: array[0..9] of string = (
         'bckj.DefaultRDM',
         'bckj.DefaultRDM1',
         'bckj.DefaultRDM2',
         'bckj.DefaultRDM3',
         'bckj.DefaultRDM4',
         'bckj.DefaultRDM5',
         'bckj.DefaultRDM6',
         'bckj.DefaultRDM7',
         'bckj.DefaultRDM8',
         'bckj.DefaultRDM9');

type
  PMapData = ^TMapData;
  TMapData = packed record
    AppHandle, ActiveHandle: HWND;
    AppFlag, PBFlag: Byte;
    Data: array [0..1024] of Char;
  end;

  PUserRecord = ^TUserRecord;
  TUserRecord = record
    Bz: Byte;
    ValueSize: Integer;
    ValueBuf: Pointer;
    PassSize: Integer;
    PassBuf: Pointer;
  end;

function Csh: Boolean;
procedure QuitNow;
procedure ExceptionHandler(ExceptObject: TObject; ExceptAddr: Pointer); far;
procedure GetSystemParams;
function GetCurrentDateTime: string;
function ShowHintString(HintString: string; CaptionString: string = '提示'; HideFlag: Boolean = True): TWinControl;
function XorString(Str: string): string;
procedure GetRegisterHandle;
function GetRegisterInfo(Index: Integer = 0): string;
function GetRegisterUser: string;
function ShowRegisterForm: Boolean;
function SetRegisterInfo(User, Info: string): Boolean;
function SetLanguage(PLanguage: Pointer): Boolean;
function SetRegisterHint(PHint: Pointer): Boolean;
procedure Compress(InBuf: Pointer; InBytes: Integer; var OutBuf: Pointer; var OutBytes: Integer; Password: string = '');
procedure Decompress(InBuf: Pointer; InBytes: Integer; var OutBuf: Pointer; var OutBytes: Integer; Password: string = ''; OutEstimate: Integer = 0);
function StringCompress(SourceString: string; Password: string = ''; HFlag: Boolean = True): string;
function StringDecompress(SourceString: string; Password: string = ''; HFlag: Boolean = True): string;
procedure Encrypt(InBuf: Pointer; InBytes: Integer; var OutBuf: Pointer; var OutBytes: Integer; Password: string = '');
procedure Decrypt(InBuf: Pointer; InBytes: Integer; var OutBuf: Pointer; var OutBytes: Integer; Password: string = ''; OutEstimate: Integer = 0);
function StringEncrypt(SourceString: string; Password: string = ''; HFlag: Boolean = True): string;
function StringDecrypt(SourceString: string; Password: string = ''; HFlag: Boolean = True): string;

var
  RegisterHandle: HWND;
  RegisterStrings: TStringList;
  Connections, SystemParams: TStringList;
  FCshSuccess: Boolean;
  FontCharset: TFontCharset = GB2312_CHARSET;
  FontName: TFontName = '宋体';
  FontSize: Integer = 9;
  Str_Warn: string = '警告';
  Str_Hint: string = '提示';
  IgnoreException: Boolean;
  hFileMap: THandle;
  hMapView: PMapData;

implementation

uses
  ComObj, RDMUnit;

function Csh: Boolean;
begin
  Result := FCshSuccess;
  if not Result then
  begin
    ExceptProc := @ExceptionHandler;
    Randomize;
    Connections := TStringList.Create;
    SystemParams := TStringList.Create;
    FCshSuccess := True;
    GetSystemParams;
    Result := FCshSuccess;
  end;
end;

procedure QuitNow;
begin
  if IsLibrary then
    ExitProcess(0)
  else
    Halt(0);
end;

procedure ExceptionHandler(ExceptObject: TObject; ExceptAddr: Pointer);
var
  Buffer: array [0..1023] of Char;
begin
  ExceptionErrorMessage(ExceptObject, ExceptAddr, Buffer, SizeOf(Buffer));
  if not IgnoreException then
    MessageBox(0, Buffer, PChar(Str_Warn), MB_OK or MB_ICONSTOP);
end;

procedure GetSystemParams;
var
  i: Integer;
  CmdFile: TextFile;
  Ch: Char;
  CmdLine: string;
  Reg: TRegistry;
  EXE: array [0..9] of string;
begin
  for i := 1 to ParamCount do
    Connections.Add(ParamStr(i));
  if FileExists(Copy(Application.ExeName, 1, Length(Application.ExeName) - Length(ExtractFileExt(Application.ExeName))) + '.cmd') then
  begin
    CmdLine := '';
    Assign(CmdFile, Copy(Application.ExeName, 1, Length(Application.ExeName) - Length(ExtractFileExt(Application.ExeName))) + '.cmd');
    Reset(CmdFile);
    try
      while not Eof(CmdFile) do
      begin
        Read(CmdFile, Ch);
        if (Ch = ' ') or (Ch = #9) then
          CmdLine := CmdLIne + #13#10
        else
          CmdLine := CmdLine + Ch;
      end;
    finally
      CloseFile(CmdFile);
    end;
    Connections.Text := CmdLine;
  end;
  for i := 1 to ParamCount do
    Connections.Add(ParamStr(i));
  for i := 0 to Connections.Count - 1 do
  begin
    if (UpperCase(Connections[i]) = '/N') or (UpperCase(Connections[i]) = '/NEUTRAL') then
      CurrentThreadModel := tmNeutral;
    if (UpperCase(Connections[i]) = '/B') or (UpperCase(Connections[i]) = '/BOTH') then
      CurrentThreadModel := tmBoth;
    if (UpperCase(Connections[i]) = '/F') or (UpperCase(Connections[i]) = '/FREE') then
      CurrentThreadModel := tmFree;
    if (UpperCase(Connections[i]) = '/A') or (UpperCase(Connections[i]) = '/APARTMENT') then
      CurrentThreadModel := tmApartment;
    if (UpperCase(Connections[i]) = '/S') or (UpperCase(Connections[i]) = '/SINGLE') then
      CurrentThreadModel := tmSingle;
    if UpperCase(Copy(Connections[i], 1, 3)) = '/T:' then
      try
        CanConnectMins := StrToInt(Copy(Connections[i], 4, Length(Connections[i]) - 3));
      except
      end;
    if UpperCase(Copy(Connections[i], 1, 6)) = '/TIME:' then
      try
        CanConnectMins := StrToInt(Copy(Connections[i], 7, Length(Connections[i]) - 6));
      except
      end;
    if (UpperCase(Connections[i]) = '/ID') or (UpperCase(Connections[i]) = '/CLSID')  or (UpperCase(Connections[i]) = '/SHOWCLSID') then
      SystemParams.Values['ShowID'] := 'Y';
    if SystemParams.Values['UserName'] = '' then
    begin
      if UpperCase(Copy(Connections[i], 1, 3)) = '/U:' then
        SystemParams.Values['UserName'] := Copy(Connections[i], 4, Length(Connections[i]) - 3);
      if UpperCase(Copy(Connections[i], 1, 6)) = '/USER:' then
        SystemParams.Values['UserName'] := Copy(Connections[i], 7, Length(Connections[i]) - 6);
      if UpperCase(Copy(Connections[i], 1, 10)) = '/USERNAME:' then
        SystemParams.Values['UserName'] := Copy(Connections[i], 11, Length(Connections[i]) - 10);
    end;
    if SystemParams.Values['Password'] = '' then
    begin
      if UpperCase(Copy(Connections[i], 1, 3)) = '/P:' then
        SystemParams.Values['Password'] := Copy(Connections[i], 4, Length(Connections[i]) - 3);
      if UpperCase(Copy(Connections[i], 1, 6)) = '/PASS:' then
        SystemParams.Values['Password'] := Copy(Connections[i], 7, Length(Connections[i]) - 6);
      if UpperCase(Copy(Connections[i], 1, 10)) = '/PASSWORD:' then
        SystemParams.Values['Password'] := Copy(Connections[i], 11, Length(Connections[i]) - 10);
    end;
    if (Copy(Connections[i], 1, 1) <> '/') and (Copy(Connections[i], 1, 1) <> '-') then
      if SystemParams.Values['UserName'] = '' then
        SystemParams.Values['UserName'] := Connections[i]
      else
        if SystemParams.Values['Password'] = '' then
          SystemParams.Values['Password'] := Connections[i];
    if UpperCase(Connections[i]) = '/UNREGSERVER' then
      SystemParams.Values['Unreg'] := 'Y';
  end;
  Connections.Clear;
  if (CanConnectMins < 0) or (CanConnectMins > 4320) then
    CanConnectMins := 0;
  if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and (Win32MinorVersion >= 10) then
    SystemParams.Values['VerInfo'] := '98ME';
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    if Win32MajorVersion = 4 then
      SystemParams.Values['VerInfo'] := 'NT4';
    if Win32MajorVersion = 5 then
    begin
      if Win32MinorVersion = 0 then
        SystemParams.Values['VerInfo'] := '2000';
      if Win32MinorVersion = 1 then
        SystemParams.Values['VerInfo'] := 'XP';
    end;
  end;
  FCshSuccess := True;
  if FCshSuccess then
  begin
    Reg := TRegistry.Create;
    try
      Reg.RootKey := HKEY_CLASSES_ROOT;
      for i := 0 to 9 do
      begin
        if Reg.OpenKey('\CLSID\' + Key[i] + '\LocalServer32', False) then
        begin
          EXE[i] := Reg.ReadString('');
          Reg.CloseKey;
          if (CurrentRDM > 9) and not FileExists(EXE[i]) then
            CurrentRDM := i;
          if (UpperCase(EXE[i]) = UpperCase(Application.ExeName)) then
          begin
            CurrentRDM := i;
            Break;
          end;
        end
        else
          if CurrentRDM > 9 then
            CurrentRDM := i;
      end;
    finally
      Reg.Free;
    end;
    if ((SystemParams.Values['Unreg'] = 'Y') and ((CurrentRDM > 9) or (UpperCase(EXE[CurrentRDM]) <> UpperCase(Application.ExeName)))) or ((CurrentRDM > 9) and (MessageBox(0, PChar('因与以下程序的CLSID冲突:'#13#10#13#10'  ' + EXE[0] + #13#10'  ' + EXE[1] + #13#10'  ' + EXE[2] + #13#10'  ' + EXE[3] + #13#10'  ' + EXE[4] + #13#10'  ' + EXE[5] + #13#10'  ' + EXE[6] + #13#10'  ' + EXE[7] + #13#10'  ' + EXE[8] + #13#10'  ' + EXE[9] + #13#10#13#10'系统无法注册COM服务器,继续运行可能会出现错误! 建议带参数'#13#10'"/unregserver"运行以上程序取消注册再运行本程序!'#13#10#13#10'现在就退出系统吗?'), '确认', MB_YESNO or MB_ICONQUESTION) = IDYES)) or ((CurrentRDM < 10) and (SystemParams.Values['ShowID'] = 'Y') and (MessageBox(0, PChar('本软件注册的接口(' + KeyName[CurrentRDM] + ')CLSID是:'#13#10 + Key[CurrentRDM] + '.'#13#10'登录成功后可以按CTRL+F1再次查看接口信息!'#13#10#13#10'继续运行系统吗?'), '确认', MB_YESNO or MB_ICONQUESTION) <> IDYES)) then
      Halt(0);
  end;
end;

function GetCurrentDateTime: string;
begin
  DateTimeToString(Result, 'yyyy.mm.dd hh:nn:ss', Now);
end;

function ShowHintString(HintString: string; CaptionString: string = '提示'; HideFlag: Boolean = True): TWinControl;
begin
  Application.ProcessMessages;
  if CaptionString = '提示' then
    CaptionString := Str_Hint;
  Result := TForm.Create(Application);
  with TForm(Result) do
  begin
    Font.Charset := GB2312_CHARSET;
    Font.Size := 9;
    Font.Name := '宋体';
    try
      Font.Charset := FontCharset;
    except
    end;
    try
      Font.Size := FontSize;
    except
    end;
    try
      Font.Name := FontName;
    except
    end;
    if Screen.CustomFormCount > 0 then
      Font.Assign(Screen.CustomForms[0].Font);
    BorderStyle := bsDialog;
    Position := poDesktopCenter;
    Caption := CaptionString;
  end;
  with TLabel.Create(Application) do
  begin
    Parent := TForm(Result);
    Font.Assign(TForm(Result).Font);
    Caption := HintString;
    AutoSize := True;
    Left := 20;
    Top := 15;
    TForm(Result).ClientWidth := Width + 39;
    TForm(Result).ClientHeight := Height + 29;
    TForm(Result).Left := (Screen.Width - TForm(Result).Width) div 2;
    TForm(Result).Top := (Screen.Height - TForm(Result).Height) div 2;
  end;
  ShowWindow(TForm(Result).Handle, SW_SHOW);
  if HideFlag then
    ShowWindow(Application.Handle, SW_HIDE);
  TForm(Result).Update;
end;

function XorString(Str: string): string;
var
  i: Integer;
begin
  Result := Str;
  for i := 1 to Length(Str) do
    Result[i] := Chr(Ord(Str[i]) xor $FF xor Lo(i));
end;

procedure GetRegisterHandle;
var
  TempStr: string;
  i: Integer;
  hFileMap: Cardinal;
  TempP: ^Cardinal;
begin
  RegisterHandle := 0;
  TempStr := GetModuleName(HInstance);
  i := Pos('\', TempStr);
  while i > 0 do
  begin
    TempStr := Copy(TempStr, 1, i - 1) + '/' + Copy(TempStr, i + 1, Length(TempStr) - i);
    i := Pos('\', TempStr);
  end;
  TempStr := TempStr + '/' + IntToHex(GetCurrentProcessID, 8);
  hFileMap := OpenFileMapping(FILE_MAP_WRITE, False, PChar(TempStr));
  if hFileMap > 0 then
  begin
    TempP := MapViewOfFile(hFileMap, FILE_MAP_WRITE, 0, 0, 0);
    if TempP <> nil then
    begin
      RegisterHandle := TempP^;
      UnmapViewOfFile(TempP);
    end;
    CloseHandle(hFileMap);
  end;
end;

function GetRegisterInfo(Index: Integer = 0): string;
var
  i, MessageResult: Integer;
begin
  Result := '';
  if Index = 0 then
    Result := 'N';
  if (Index = 4) and not IsLibrary then
    Result := Application.Title;
  if not IsWindow(RegisterHandle) then
    Exit;
  for i := 1 to 100 do
  begin
    MessageResult := SendMessage(RegisterHandle, WM_USER, 0, 1);
    if MessageResult <> -1 then
      Break;
  end;
  if MessageResult <> -1 then
  begin
    SetLength(Result, Length(PChar(MessageResult)));
    CopyMemory(@Result[1], Pointer(MessageResult), Length(Result));
    if RegisterStrings = nil then
      RegisterStrings := TStringList.Create;
    RegisterStrings.Text := Result;
    if (Index >= 0) and (Index < RegisterStrings.Count) then
      Result := RegisterStrings[Index]
    else
      Result := '';
  end;
end;

function GetRegisterUser: string;
begin
  Result := '';