文章标题

---

unit Main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, IniFiles,Graphics, Controls, Forms,
  Dialogs, IdHashMessageDigest,StdCtrls, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, IdExplicitTLSClientServerBase, ShellAPI,Registry,IdFTP,
  ComCtrls, ExtCtrls, CheckLst;
Type FileRec = Record
  FileName :string;
  Att :String;
  Size :integer;
  ModiDate :string
end;
type
  TfrmMain = class(TForm)
    btnpalBBS: TButton;
    Button10: TButton;
    IdFTP1: TIdFTP;
    Note: TMemo;
    GroupBox4: TGroupBox;
    edLicFile: TEdit;
    Button3: TButton;
    Label4: TLabel;
    edUser: TEdit;
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    功能: TTabSheet;
    lbRegFun: TListBox;
    Panel1: TPanel;
    rbReg: TRadioButton;
    rbRegDate: TRadioButton;
    edRegDate: TEdit;
    Label5: TLabel;
    rdCid: TEdit;
    memLic: TMemo;
    clbClass: TCheckListBox;
    Label3: TLabel;
    Label1: TLabel;
    cbFtpList: TComboBox;
    btnReceive: TButton;
    btnAct: TButton;

    //Procedure getActCode;

    procedure FormCreate(Sender: TObject);
  //  procedure btnReceiveClick(Sender: TObject);
    //procedure btnActClick(Sender: TObject);
    //procedure btnCheckClick(Sender: TObject);
    procedure btnpalBBSClick(Sender: TObject);
    procedure edUserChange(Sender: TObject);
    procedure rbRegClick(Sender: TObject);
    procedure rbRegDateClick(Sender: TObject);
    procedure clbClassClick(Sender: TObject);
    procedure lbRegFunClick(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
        BytesToTransfer: LongWord;

  public
    { Public declarations }
  end;


  type
TMD5 = class(TIdHashMessageDigest5);

var
  frmMain: TfrmMain;
  strLicMd5:string;
  downfilename,downloadpath:string;
  lini:Tinifile;
  FTP_ptoclose,FTP_user,FTP_psw,FTP_svrip,FTP_path:string;

implementation

{$R *.dfm}
// ================窗体动作===================
{
功能：使用传递参数确认某软件注册情况
1.接收软件名传递参数
2.检查注册档是否已认证，
3.检查正在运行的软件是否可通过（足够的金币，注册，使用期限）
4.以环境变量形式发送使用授权信息
5.运行结束是否进入ftp真伪认证，一次真伪认证可使用100次。
}
function GetCDiskDriveInfo: Pchar; // 获得C盘ID
var
  InfoID: Byte;
  NotUsed: DWORD;
  VolumeFlags: DWORD;
  VolumeInfo: array [0 .. MAX_PATH] of Char;
  VolumeSerialNumber: DWORD;
begin
  try
    GetVolumeInformation(Pchar('C:\'), VolumeInfo, SizeOf(VolumeInfo),
      @VolumeSerialNumber, NotUsed, VolumeFlags, nil, 0);
    case 1 of
      1:
        Result := Pchar(Format('%8.8X', [VolumeSerialNumber]));
      2:
        Result := VolumeInfo;
    else
      Result := 'JiiYi';
    end;
  except
    on E: Exception do
      Result := '执行错误!';
  end;
end;

function StreamToMD5(S: TFileStream): String;
var
  Md5Encode: TMD5;
begin
  Md5Encode := TMD5.Create;
  try
    Result := Md5Encode.HashStreamAsHex(S);
  finally
    Md5Encode.Free;
  end;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
var
  licFile, licMD5: string;
  filesen: TFileStream;
begin

  licFile := 'C:\PalPCB\Allegro\Pcbenv\License.dat';
  if fileexists(licFile) then
  begin
    // 读取MD5码
    filesen := TFileStream.Create(licFile, fmOpenRead or fmShareExclusive);
    licMD5 := StreamToMD5(filesen);
    strLicMd5 := licMD5;
    filesen.Free;
  end
  else
    strLicMd5 := 'File not found!';

  //表单自动填写

  downloadpath := 'C:\PalEDA\Allegro\Env\';                                     //env路径
  rdCid.Text := GetCDiskDriveInfo;    // 获取C盘ID                              //机器码
  if not DirectoryExists(downloadpath) then ForceDirectories(downloadpath);

  downfilename := downloadpath + rdCid.Text + '.reg';                           //注册文件名
  edRegDate.Text:=datetostr(now+365);

  //lic文件读写
  edLicFile.Text:= downloadpath + rdCid.Text +'.dat';                           //表单文件名
  if FileExists(edLicFile.Text) then
  memLic.Lines.LoadFromFile(edLicFile.Text);
  lini:=Tinifile.Create(edLicFile.Text);
  lini.WriteString('instructions','ComputerID',rdCid.Text);
  edUser.Text:=lini.ReadString('instructions','UserName','');


//  getActCode;
end;

procedure TfrmMain.edUserChange(Sender: TObject);
begin
  lini.WriteString('instructions','UserName',edUser.Text);
  memLic.Lines.LoadFromFile(edLicFile.Text);
end;

procedure TfrmMain.clbClassClick(Sender: TObject);
begin
case clbClass.ItemIndex of
0:begin
  if (clbClass.Checked[clbClass.ItemIndex] and rbReg.Checked)     then lini.WriteString('instructions','File','reg');
  if (clbClass.Checked[clbClass.ItemIndex] and rbRegDate.Checked) then lini.WriteString('instructions','File',edRegDate.Text);
  if not clbClass.Checked[clbClass.ItemIndex]                     then lini.WriteString('instructions','File','');
end;
1:begin
  if (clbClass.Checked[clbClass.ItemIndex] and rbReg.Checked)     then lini.WriteString('instructions','Display','reg');
  if (clbClass.Checked[clbClass.ItemIndex] and rbRegDate.Checked) then lini.WriteString('instructions','Display',edRegDate.Text);
  if not clbClass.Checked[clbClass.ItemIndex]                     then lini.WriteString('instructions','Display','');
end;
2:begin
  if (clbClass.Checked[clbClass.ItemIndex] and rbReg.Checked)     then lini.WriteString('instructions','Pcbenv','reg');
  if (clbClass.Checked[clbClass.ItemIndex] and rbRegDate.Checked) then lini.WriteString('instructions','Pcbenv',edRegDate.Text);
  if not clbClass.Checked[clbClass.ItemIndex]                     then lini.WriteString('instructions','Pcbenv','');
end;
3:begin
  if (clbClass.Checked[clbClass.ItemIndex] and rbReg.Checked)     then lini.WriteString('instructions','Logic','reg');
  if (clbClass.Checked[clbClass.ItemIndex] and rbRegDate.Checked) then lini.WriteString('instructions','Logic',edRegDate.Text);
  if not clbClass.Checked[clbClass.ItemIndex]                     then lini.WriteString('instructions','Logic','');
end;
4:begin
  if (clbClass.Checked[clbClass.ItemIndex] and rbReg.Checked)     then lini.WriteString('instructions','Edit','reg');
  if (clbClass.Checked[clbClass.ItemIndex] and rbRegDate.Checked) then lini.WriteString('instructions','Edit',edRegDate.Text);
  if not clbClass.Checked[clbClass.ItemIndex]                     then lini.WriteString('instructions','Edit','');
end;
5:begin
  if (clbClass.Checked[clbClass.ItemIndex] and rbReg.Checked)     then lini.WriteString('instructions','Place','reg');
  if (clbClass.Checked[clbClass.ItemIndex] and rbRegDate.Checked) then lini.WriteString('instructions','Place',edRegDate.Text);
  if not clbClass.Checked[clbClass.ItemIndex]                     then lini.WriteString('instructions','Place','');
end;
6:begin
  if (clbClass.Checked[clbClass.ItemIndex] and rbReg.Checked)     then lini.WriteString('instructions','Route','reg');
  if (clbClass.Checked[clbClass.ItemIndex] and rbRegDate.Checked) then lini.WriteString('instructions','Route',edRegDate.Text);
  if not clbClass.Checked[clbClass.ItemIndex]                     then lini.WriteString('instructions','Route','');
end;
7:begin
  if (clbClass.Checked[clbClass.ItemIndex] and rbReg.Checked)     then lini.WriteString('instructions','Find','reg');
  if (clbClass.Checked[clbClass.ItemIndex] and rbRegDate.Checked) then lini.WriteString('instructions','Find',edRegDate.Text);
  if not clbClass.Checked[clbClass.ItemIndex]                     then lini.WriteString('instructions','Find','');
end;
8:begin
  if (clbClass.Checked[clbClass.ItemIndex] and rbReg.Checked)     then lini.WriteString('instructions','Compare','reg');
  if (clbClass.Checked[clbClass.ItemIndex] and rbRegDate.Checked) then lini.WriteString('instructions','Compare',edRegDate.Text);
  if not clbClass.Checked[clbClass.ItemIndex]                     then lini.WriteString('instructions','Compare','');
end;
9:begin
  if (clbClass.Checked[clbClass.ItemIndex] and rbReg.Checked)     then lini.WriteString('instructions','Tools','reg');
  if (clbClass.Checked[clbClass.ItemIndex] and rbRegDate.Checked) then lini.WriteString('instructions','Tools',edRegDate.Text);
  if not clbClass.Checked[clbClass.ItemIndex]                     then lini.WriteString('instructions','Tools','');
end;
10:begin
  if (clbClass.Checked[clbClass.ItemIndex] and rbReg.Checked)     then lini.WriteString('instructions','Skill','reg');
  if (clbClass.Checked[clbClass.ItemIndex] and rbRegDate.Checked) then lini.WriteString('instructions','Skill',edRegDate.Text);
  if not clbClass.Checked[clbClass.ItemIndex]                     then lini.WriteString('instructions','Skill','');
end;

end;

memLic.Lines.LoadFromFile(edLicFile.Text);
end;

procedure TfrmMain.rbRegClick(Sender: TObject);
var i:integer;
begin
edRegDate.Enabled:=rbRegDate.Checked;
for I := 0 to clbClass.Items.Count - 1 do  clbClass.Checked[i]:=false;

if lini.ReadString('instructions','File','')='reg' then clbClass.Checked[0]:=true;
if lini.ReadString('instructions','Display','')='reg' then clbClass.Checked[1]:=true;
if lini.ReadString('instructions','Pcbenv','')='reg' then clbClass.Checked[2]:=true;
if lini.ReadString('instructions','Logic','')='reg' then clbClass.Checked[3]:=true;
if lini.ReadString('instructions','Edit','')='reg' then clbClass.Checked[4]:=true;
if lini.ReadString('instructions','Place','')='reg' then clbClass.Checked[5]:=true;
if lini.ReadString('instructions','Route','')='reg' then clbClass.Checked[6]:=true;
if lini.ReadString('instructions','Find','')='reg' then clbClass.Checked[7]:=true;
if lini.ReadString('instructions','Compare','')='reg' then clbClass.Checked[8]:=true;
if lini.ReadString('instructions','Tools','')='reg' then clbClass.Checked[9]:=true;
if lini.ReadString('instructions','Skill','')='reg' then clbClass.Checked[10]:=true;
end;

procedure TfrmMain.rbRegDateClick(Sender: TObject);
var i:integer;
begin
edRegDate.Enabled:=rbRegDate.Checked;
for I := 0 to clbClass.Items.Count - 1 do  clbClass.Checked[i]:=false;
if lini.ReadString('instructions','File','')=edRegDate.Text then clbClass.Checked[0]:=true;
if lini.ReadString('instructions','Display','')=edRegDate.Text then clbClass.Checked[1]:=true;
if lini.ReadString('instructions','Pcbenv','')=edRegDate.Text then clbClass.Checked[2]:=true;
if lini.ReadString('instructions','Logic','')=edRegDate.Text then clbClass.Checked[3]:=true;
if lini.ReadString('instructions','Edit','')=edRegDate.Text then clbClass.Checked[4]:=true;
if lini.ReadString('instructions','Place','')=edRegDate.Text then clbClass.Checked[5]:=true;
if lini.ReadString('instructions','Route','')=edRegDate.Text then clbClass.Checked[6]:=true;
if lini.ReadString('instructions','Find','')=edRegDate.Text then clbClass.Checked[7]:=true;
if lini.ReadString('instructions','Compare','')=edRegDate.Text then clbClass.Checked[8]:=true;
if lini.ReadString('instructions','Tools','')=edRegDate.Text then clbClass.Checked[9]:=true;
if lini.ReadString('instructions','Skill','')=edRegDate.Text then clbClass.Checked[10]:=true;
end;

procedure TfrmMain.lbRegFunClick(Sender: TObject);
begin
case lbRegFun.ItemIndex of
0:begin
  lini.WriteString('instructions','File',datetostr(now+365));
  lini.WriteString('instructions','Display',datetostr(now+365));
  lini.WriteString('instructions','Pcbenv',datetostr(now+365));
  lini.WriteString('instructions','Logic',datetostr(now+365));
  lini.WriteString('instructions','Edit',datetostr(now+365));
  lini.WriteString('instructions','Place',datetostr(now+365));
  lini.WriteString('instructions','Route',datetostr(now+365));
  lini.WriteString('instructions','Find',datetostr(now+365));
  lini.WriteString('instructions','Compare',datetostr(now+365));
  lini.WriteString('instructions','Tools',datetostr(now+365));
  lini.WriteString('instructions','Skill',datetostr(now+365));
end;
end;
memLic.Lines.LoadFromFile(edLicFile.Text);
end;

procedure TfrmMain.Button3Click(Sender: TObject);
begin
  lini.WriteString('instructions','ModifyDate',datetostr(now));

 FTP_ptoclose:='PalPCB';
 FTP_user:='PalPCB';
 FTP_psw:='palpilot';
 FTP_svrip:='ftp.palpilot.com.tw';
 FTP_path:='/FTP_A/PE/PalPCB/test';

end;


//--------------------帮助---------------------
procedure TfrmMain.btnpalBBSClick(Sender: TObject);
var
  qskype: string;
begin
  qskype := 'skype:?chat&blob=cLCKxLNh9O3ruyy7NNYdQUXoUORDrK-KVcwsO3fsOZNyi7y0CFMdbxa-R3hTkMOZyN9dEAxwkpyj13un';
  ShellExecute(handle, 'open', pwidechar(qskype), '', '', SW_NORMAL);
end;


end.













// =====================栓查注册档========================
procedure TfrmMain.btnCheckClick(Sender: TObject);
var
  Reg: TRegistry;
  AppKey, regSoft, keyname, regkey: string;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKey_Current_User;
    // 设置根键，
    AppKey := '\Software\PalPCB\Reg';
    keyname := rdCid.Text;

    if not Reg.OpenKey(AppKey, true) then
    begin
      Reg.CreateKey(AppKey);
      Reg.OpenKey(AppKey, true);
    end;
    Reg.OpenKey(AppKey, true);
    regkey := Reg.ReadString(keyname);
    if strLicMd5 = regkey then
      Note.Lines.Add('License.dat==>已认证！')
    else
      Note.Lines.Add('License.dat==>未认证或被修改，请重新提交！') finally
  end;
end;

procedure TfrmMain.btnViewClick(Sender: TObject);
var
  sllicFile: Tstringlist;
begin
  sllicFile := Tstringlist.Create;
  sllicFile.LoadFromFile(edLicFile.Text);
  showmessage(sllicFile.Text);
end;







function SetGlobalEnvironment(const Name,Value:string):boolean;
const
 REG_LOCATION='System/CurrentControlSet/Control/Session Manager/Environment';
var
 R:DWORD;
begin
 with TRegistry.Create do
 try
   RootKey :=HKEY_LOCAL_MACHINE;
   Result :=OpenKey(REG_LOCATION,True);
   if Result then
   begin
     WriteString(Name,Value);
     SendMessage(HWND_BROADCAST,WM_SETTINGCHANGE,0,integer(Pchar('Environment')));
//      SendMessageTimeOut(HWND_BROADCAST,WM_SETTINGCHANGE,0,integer(Pchar('Environment')),SMTO_NORMAL,1000,R);
   end;
 finally
   Free;
 end;
end;



//===================激活====================
Procedure TfrmMain.getActCode;
var
  stlCode: Tstringlist;
begin
  stlCode := Tstringlist.Create;
  stlCode.LoadFromFile(downfilename);
  edActCode.Text := copy(stlCode[3], pos('"="', stlCode[3]) + 3,
    length(stlCode[3]) - pos('"="', stlCode[3]) - 3);
end;







procedure TfrmMain.btnReceiveClick(Sender: TObject);
var
  FTP_ptoclose, FTP_user, FTP_psw, FTP_svrip, FTP_path: string;
  ls_user, ls_psw, ls_svrip, ls_path, ls_ptoclose: string;
  i, j: Longint;
  FDetail: FileRec;
  stl, strlist: Tstringlist;
  ftppath: string;

  // ftp协议
procedure P_ChangeDir(Dir: String);
  begin
    // 清空列表
    strlist := Tstringlist.Create;
    strlist.Clear;
    IdFTP1.ChangeDir(Dir);
    IdFTP1.List(strlist);
    if strlist.Count > 0 then
      if AnsiPos('total', strlist.Strings[0]) > 0 then
        strlist.Delete(0);
    ftppath := IdFTP1.RetrieveCurrentDir;

  end;

 Procedure p_connect(subfolder: string);
  begin
    try
      ls_ptoclose := FTP_ptoclose;
      ls_user := FTP_user;
      ls_psw := FTP_psw; // 不解密
      ls_svrip := FTP_svrip;
      ls_path := FTP_path + subfolder;
    finally
      // upini.Free;
    end;

    with IdFTP1 do
      try
        Username := ls_user;
        Password := ls_psw;
        Host := ls_svrip;
        try
          Note.Lines.Add('开始连接ftp服务器...');
          Connect;
        except
          on E: Exception do
          begin
            Update;
            Application.ProcessMessages;
            Note.Lines.Add('连接失败.[' + E.Message + '],! ');
            // Off automatically after 5 seconds..
          end;
        end;
      finally
        if Connected then
        begin
          Note.Lines.Add('连接成功，正在下载激活档');
          P_ChangeDir(FTP_path);
        end
      end;

  end;

// 尝试主动作
begin
  if cbFtpList.Text = 'Ftp://PalPCB@ftp.palpilot.com.tw/' then
  begin
    FTP_ptoclose := 'PalPCB';
    FTP_user := 'PalPCB';
    FTP_psw := 'palpilot1#';
    FTP_svrip := '211.22.10.210';
    FTP_path := '/PalPCB/Key';
  end;
  p_connect('');
  if not(IdFTP1.Connected) then  exit;
  if not DirectoryExists(downloadpath) then     ForceDirectories(downloadpath);
  if fileexists(downfilename) then     deletefile(downfilename);
  P_ChangeDir(FTP_path);
  BytesToTransfer := IdFTP1.Size(FTP_path + '/' + rdCid.Text + '.reg');
  IdFTP1.Get(rdCid.Text + '.reg', downfilename, false);
  Application.ProcessMessages;
  Note.Lines.Add(downfilename + ' ==> 文件已下载!');
  IdFTP1.Quit;
  Application.ProcessMessages;
  getActCode;
end;

procedure TfrmMain.btnActClick(Sender: TObject);
var
  S: string;
begin
  S := 'C:\PalPCB\Allegro\pcbenv\' + rdCid.Text + '.reg';
  ShellExecute(handle, 'open', 'regedit.exe', Pchar(S), '', SW_HIDE);
end;