regunit.pas

采用加密算法进行管理用户密码采用加密算法进行管理用户密码

unit RegUnit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons,ReadSerialUnit,IniFiles,SetFileU,WNDES,StrUtils;
const
  sKeyFilName            ='License.cer';
  EncryKey               ='WSYZwYhs';
type
  TFrmReg = class(TForm)
    Label1: TLabel;
    Edit1: TEdit;
    BtnCreateSerial: TSpeedButton;
    BtnHaveLicense: TSpeedButton;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    BtnAuto: TSpeedButton;
    procedure FormShow(Sender: TObject);
    procedure BtnHaveLicenseClick(Sender: TObject);
    procedure BtnCreateSerialClick(Sender: TObject);
    procedure BtnAutoClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    sInstrumentType:String;
    g_StrAppPath:String;
    function ChkCDROM(l_Path:String):boolean;
    Function GetCDROMDriveString():String;
    function SearchLicenseFile(strPath,sFileName:String):String;
    function RegLicenseFile(sFileName:String):boolean;
     
  end;
  function HaveLicense(StrAppPath,InstrumentType:String):boolean;  stdcall;

var
  FrmReg: TFrmReg;

implementation

{$R *.dfm}
function HaveLicense(StrAppPath,InstrumentType:String):boolean;  stdcall;
var
  SetFile: TSetFile;
  strResult:String;
  StrGet:String;
  Re: TResult;
  F: TFileStream;
  nLen:Integer;
  buf:array [0..2048]of char;
begin
 Result:=false;
 if not FileExists(StrAppPath+sKeyFilName) then exit;
 try
   SetFile := CreateSetFile;
   SetFile.SetFileName :=PChar(StrAppPath+sKeyFilName);
   strResult:='';
   DeleteFile('y.kfo');
   F := TFileStream.Create('y.kfo', fmCreate);
   F.Size := 0;
   Re := SetFile.LoadSet('Serial',F);
   if Re <> RDataCheckErr then
   begin
     F.Position :=0;
     nLen:=0;
     nLen:=F.Size;
     FillChar(buf,2049,0);
     F.Read(buf,nLen);
     strResult:=StrPas(buf);
   end;
   StrGet:= Trim(ReadHdSerial)+InstrumentType+GetCPUIDStr ;
   StrGet :=AnsiReplaceText(StrGet,'O','0');    //2006-1-19
   StrGet :=AnsiReplaceText(StrGet,'o','0');
   if DESryStrHex(strResult,EncryKey)=StrGet then
      Result:=true;

 finally
   F.Free ;
   SetFile.Free;
   DeleteFile('y.kfo');
 end;

end;

//功能:在指定路径下搜索指定的文件（包含子目录）
//参数:strPath: 搜索路径; sFileName  文件名

//返回值: 空表示没有找到，否则返回全路径文件名
//
function TFrmReg.SearchLicenseFile(strPath,sFileName:String):String;
var
 fRec :TSearchRec;
 tmpPathName,tmpstring,PathName:String ;
 iLen:Integer;

begin
 Application.ProcessMessages;

 PathName:=strPath;
 iLen:=StrLen(PChar(PathName));
 if(PathName[iLen]<>'\')then
 begin
   PathName:=PathName+'\';
 end;
 tmpPathName:=PathName+sFileName;
 Result:='';
 //找第一个文件
 if(FindFirst(tmpPathName,faAnyFile,fRec)=0 ) then
 begin
   if fRec.Attr and faDirectory = faDirectory then
   begin  //是子目录
     tmpstring:= SearchLicenseFile(PathName +Trim(fRec.Name) + '\',sFileName);
     if Trim(tmpstring)<>'' then
     begin
       Result:= tmpstring;
       FindClose(fRec);
       Exit;
     end;
   end
   else
   begin
     tmpstring:=ExtractFileName(fRec.Name);
     if UpperCase(tmpstring)= UpperCase(sFileName) then
     begin
       Result:= PathName +fRec.Name;
       FindClose(fRec);
       Exit;
     end;
   end;
 end
 else
 begin
   FindClose(fRec);
   exit;
 end;

 while(true) do
 begin
   if(FindNext(fRec)=0 )then
   begin
     if fRec.Attr and faDirectory = faDirectory then
     begin  //是子目录
       tmpstring:= SearchLicenseFile(PathName +Trim(fRec.Name) + '\',sFileName);
       if Trim(tmpstring)<>'' then
       begin
         Result:= tmpstring;

         break;
       end;
     end
     else
     begin
       tmpstring:=ExtractFileName(fRec.Name);
       if UpperCase(tmpstring)= UpperCase(sFileName) then
       begin
         Result:= PathName +fRec.Name;
         break;
       end;
     end;  // end else 
   end   //end  if(FindNext(fRec)=0 )then
   else break;
 end;
 FindClose(fRec);
end;

//得到光驱盘符
Function  TFrmReg.GetCDROMDriveString():String;
var
  i:Integer;
const strDrive='ABCDEFGHIJKLMNOPQRSTUVWXYZ';
begin
  Result:='D:\';
  {
    如果返回值为5，表示光盘。
    返回值为2表示软盘。
    返回值为3表示硬盘。
    返回值为1表示该盘符不存在。

  }
  for i:=0 to 25 do
  begin
    if (GetDriveType(PChar(strDrive[i]+':\'))=5) then
    begin
      Result:=strDrive[i]+':\';
      break;
    end;
  end;

end;

function TFrmReg.ChkCDROM(l_Path:String):boolean;
var
  i: DWORD;

  l_Numb: DWORD;
begin
  { 监测光驱是否就绪 }
   l_Numb := 0;

  GetVolumeInformation(Pchar(l_Path), nil, 0, @l_Numb, i, i, nil, 0);
  if l_Numb <> 0 then
    Result := true
  else
    Result := false;
end;
procedure TFrmReg.FormShow(Sender: TObject);
begin
  
  Edit1.Text :=Trim(ReadHdSerial)+sInstrumentType+GetCPUIDStr;
  Edit1.Text :=AnsiReplaceText(Edit1.Text,'O','0');
  Edit1.Text :=AnsiReplaceText(Edit1.Text,'o','0');
end;

procedure TFrmReg.BtnHaveLicenseClick(Sender: TObject);


begin
  if OpenDialog1.Execute then
  begin
    if RegLicenseFile(OpenDialog1.FileName) then Close;
     
  end; 
end;
//验证注册文件
function TFrmReg.RegLicenseFile(sFileName:String):boolean;
var
   Attributes: Word;
begin
    Result:=false;
    CopyFile(PChar(sFileName),PChar(g_StrAppPath+sKeyFilName),false);
    Attributes:=FileGetAttr(g_StrAppPath+sKeyFilName);
    //去掉只读属性
    if  (Attributes and faReadOnly)  = faReadOnly  then
    begin
       Attributes:=Attributes and not faReadOnly;
       FileSetAttr(g_StrAppPath+sKeyFilName, Attributes);
    end;
    if not HaveLicense(g_StrAppPath,sInstrumentType) then
    begin
      DeleteFile(g_StrAppPath+sKeyFilName);
      MessageDlg('对不起，这不是需要的注册许可证文件',mtWarning, [mbOk], 0);
    end
    else
    begin
      Result:=true;
      MessageDlg('注册成功，谢谢！',mtInformation, [mbOk], 0);

    end;
end;
procedure TFrmReg.BtnCreateSerialClick(Sender: TObject);
var
  StrFileName,StrExt:String;
  mF:TIniFile;
begin
   if SaveDialog1.Execute then
   begin

     StrExt:=UpPerCase(ExtractFileExt(SaveDialog1.FileName));
     StrFileName:= SaveDialog1.FileName;
     if StrExt<>'.SER' then
       StrFileName:= SaveDialog1.FileName+'.Ser';
     try
       mF:=TIniFile.Create(StrFileName);
       mF.WriteString('Serial','SerialNumber',Trim(ReadHdSerial)+sInstrumentType+GetCPUIDStr);
     finally
       mF.Free ;
     end;
   end;
end;

procedure TFrmReg.BtnAutoClick(Sender: TObject);
var
  sPath,sFileName:String;
begin
   sPath:=GetCDROMDriveString();
  if ChkCDROM(sPath)then
  begin
    sFileName:= SearchLicenseFile(sPath,sKeyFilName);
    if Trim(sFileName)<>'' then
    begin
       if RegLicenseFile(sFileName) then Close;
    end
    else
    begin
       MessageDlg('没有找到需要的注册证许可文件',mtInformation, [mbOk], 0);
    end;
  end
  else
  begin
    MessageDlg('请将长沙瑞翔科技有限公司的安装程序光盘放入光驱，谢谢！',mtInformation, [mbOk], 0);
  end;
end;

procedure TFrmReg.FormCreate(Sender: TObject);
begin
   g_StrAppPath :=ExtractFilePath(Application.ExeName);
end;

end.