LoginFrm.pas 9.7 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365
  1. {*******************************************************************************
  2. 单元名称: ScLoginFrm.pas
  3. 单元说明: 网络版PHP Web页面登录方式。
  4. 作者时间: Chenshilong, 2012-5-13
  5. *******************************************************************************}
  6. unit LoginFrm;
  7. interface
  8. uses
  9. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  10. Dialogs, JimCombos, ExtCtrls, StdCtrls, cxLookAndFeelPainters,
  11. cxTextEdit, cxButtons, cxControls, cxEdit,
  12. cxMaskEdit, cxDropDownEdit, HookEdit, cxContainer, XPMenu, cslLabel,
  13. IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP,
  14. CslButton, OleCtrls, SHDocVw, DB, ADODB, Menus;
  15. type
  16. TLoginFrm = class(TForm)
  17. edtPW: TEdit;
  18. lblForgetPW: TcslLabel;
  19. lblVer: TLabel;
  20. shpAccount: TShape;
  21. imgBG: TImage;
  22. btnLogin: TCslButton;
  23. lblReg: TCslLabel;
  24. btnClose: TCslButton;
  25. lblProductName: TLabel;
  26. shpPW: TShape;
  27. wbLogin: TWebBrowser;
  28. pnlLocalServer: TPanel;
  29. btnLocalLogin: TCslButton;
  30. lblLocalHelp: TCslLabel;
  31. lblLocalServer: TCslLabel;
  32. cbUser: TcxComboBox;
  33. pmLogin: TPopupMenu;
  34. nClearAccount: TMenuItem;
  35. procedure edtPWKeyDown(Sender: TObject; var Key: Word;
  36. Shift: TShiftState);
  37. procedure FormCreate(Sender: TObject);
  38. procedure btnLoginClick(Sender: TObject);
  39. procedure img1Click(Sender: TObject);
  40. procedure shpAccountMouseDown(Sender: TObject; Button: TMouseButton;
  41. Shift: TShiftState; X, Y: Integer);
  42. procedure shpPWMouseDown(Sender: TObject; Button: TMouseButton;
  43. Shift: TShiftState; X, Y: Integer);
  44. procedure btnCloseClick(Sender: TObject);
  45. procedure FormDestroy(Sender: TObject);
  46. procedure cbUserKeyDown(Sender: TObject; var Key: Word;
  47. Shift: TShiftState);
  48. procedure cbUserClick(Sender: TObject);
  49. procedure nClearAccountClick(Sender: TObject);
  50. private
  51. { Private declarations }
  52. FUsersCon: TADOConnection;
  53. FUsersQry: TADOQuery;
  54. procedure ReadCloudUser;
  55. procedure WriteCloudUser;
  56. public
  57. { Public declarations }
  58. end;
  59. function LoginForm: Boolean;
  60. implementation
  61. uses
  62. ScUtils, ShellAPI, IniFiles, ScConfig, Md5, PHPWebDm, ConstUnit;
  63. {$R *.dfm}
  64. function LoginForm: Boolean;
  65. var
  66. Form: TLoginFrm;
  67. begin
  68. Result := False;
  69. Form := TLoginFrm.Create(nil);
  70. try
  71. if Form.ShowModal = mrOK then
  72. begin
  73. Result := True;
  74. Form.WriteCloudUser;
  75. end;
  76. finally
  77. Form.Free;
  78. end;
  79. end;
  80. { TLoginFrm }
  81. procedure TLoginFrm.edtPWKeyDown(Sender: TObject; var Key: Word;
  82. Shift: TShiftState);
  83. begin
  84. if Key = VK_Return then
  85. btnLoginClick(Sender);
  86. end;
  87. procedure TLoginFrm.FormCreate(Sender: TObject);
  88. var SL: TStringList;
  89. ini: TIniFile;
  90. begin
  91. SetClassLong(Handle, GCL_STYLE, GetClassLong(Handle, GCL_STYLE) or CS_DROPSHADOW);
  92. Set8087CW(Default8087CW or $0004);
  93. Set8087CW(Longword($133f));
  94. ini := TIniFile.Create(ExtractFilePath(Application.ExeName) + 'Cloud.ini');
  95. try
  96. G_Server := ini.ReadString('URL', 'Server', '');
  97. G_ServerType := ini.ReadString('URL', 'ServerType', '');
  98. G_CompanyName := ini.ReadString('URL', 'CompanyName', '');
  99. G_MeasureURL := 'http://' + G_Server + ini.ReadString('URL', 'MeasureURL', '');
  100. finally
  101. ini.Free;
  102. end;
  103. if Trim(G_CompanyName) <> '' then
  104. lblProductName.Caption := G_CompanyName
  105. else
  106. lblProductName.Caption := G_ProductName;
  107. // 服务器:1公有 2私有
  108. if G_ServerType = '2' then
  109. begin
  110. pnlLocalServer.Visible := True;
  111. lblLocalServer.URL := G_Server;
  112. lblLocalServer.Hint := G_Server;
  113. end
  114. else if G_ServerType = '1' then
  115. begin
  116. pnlLocalServer.Visible := False;
  117. end;
  118. lblReg.URL := PHPWeb.RegURL;
  119. lblForgetPW.URL := PHPWeb.PwdURL;
  120. lblVer.Caption := G_ProductName + ' ' + ScGetVersion;
  121. // lblVer.Left := lblProductName.Left + lblProductName.Width + 7;
  122. ReadCloudUser;
  123. SL := TStringList.Create;
  124. try
  125. SL.Clear;
  126. SL.Add('about: <body><font size=4 color=Green>') ;
  127. SL.Add('正在打开网页请稍候...');
  128. SL.Add('</font></body>');
  129. wbLogin.Navigate(SL.Text);
  130. wbLogin.Navigate(PHPWeb.LoginBannerURL);
  131. finally
  132. end;
  133. end;
  134. procedure TLoginFrm.btnLoginClick(Sender: TObject);
  135. var sInfo, sURL, sCheckCode, sMD5PW: string;
  136. begin
  137. case PHPWeb.Login(cbUser.Text, edtPW.Text, sInfo, sCheckCode) of
  138. ltCon:
  139. begin
  140. if Trim(sInfo) <> '' then
  141. Application.MessageBox(PChar(sInfo), '新版本提示', MB_OK + MB_ICONINFORMATION);
  142. ModalResult := mrOk;
  143. end;
  144. ltLoginFail:
  145. begin
  146. Application.MessageBox(PChar(sInfo), '操作提醒', MB_OK + MB_ICONWARNING);
  147. edtPW.SetFocus;
  148. edtPW.SelectAll;
  149. ModalResult := mrNone;
  150. end;
  151. ltUpdate:
  152. begin
  153. // 无法对PHP返回的字符串进行排版。这里使用Delphi自身的字符串。
  154. sInfo := '尊敬的用户:' + #13#13 +
  155. '系统检测出您是通过SmartCost旧版本程序注册了本帐户(' + Trim(cbUser.Text) +
  156. '),因系统升级,为保障您的帐户安全和更好的为您服务,' + #13#13 +
  157. '我们需要对您的邮箱进行有效性验证,并需要您重置该帐户的密码以保证您的帐号在新程序上能够正常使用。' + #13#13 +
  158. '请点击“确定”按钮打开密码重置页面。';
  159. Application.MessageBox(PChar(sInfo), '升级提示', MB_OK + MB_ICONINFORMATION);
  160. edtPW.SetFocus;
  161. edtPW.SelectAll;
  162. ModalResult := mrNone;
  163. Screen.Cursor := crHourGlass;
  164. try
  165. sURL := ConfigInfo.OldUserResetPwdURL + '?CheckCode=' + sCheckCode;
  166. ShellExecute(Application.Handle, 'open', PChar(sURL), nil, nil, SW_SHOWNORMAL);
  167. finally
  168. Screen.Cursor := crDefault;
  169. end;
  170. end;
  171. ltIncomplete:
  172. begin
  173. Application.MessageBox(PChar(sInfo), '系统提示', MB_OK + MB_ICONINFORMATION);
  174. ModalResult := mrNone;
  175. Screen.Cursor := crHourGlass;
  176. try
  177. sMD5PW := GetMD5(edtPW.Text);
  178. sURL := Format('%s?Account=%s&Pwd=%s', [ConfigInfo.WebLoginURL,
  179. cbUser.Text, sMD5PW]);
  180. ShellExecute(Application.Handle, 'open', PChar(sURL), nil, nil, SW_SHOWNORMAL);
  181. finally
  182. Screen.Cursor := crDefault;
  183. end;
  184. end;
  185. ltDisCon:
  186. begin
  187. Application.MessageBox('当前网络状态较差,无法连接云端,请重新尝试!', '操作提醒', MB_OK + MB_ICONWARNING);
  188. ModalResult := mrNone;
  189. end;
  190. end;
  191. end;
  192. procedure TLoginFrm.img1Click(Sender: TObject);
  193. begin
  194. Close;
  195. end;
  196. procedure TLoginFrm.shpAccountMouseDown(Sender: TObject; Button: TMouseButton;
  197. Shift: TShiftState; X, Y: Integer);
  198. begin
  199. cbUser.SetFocus;
  200. end;
  201. procedure TLoginFrm.shpPWMouseDown(Sender: TObject; Button: TMouseButton;
  202. Shift: TShiftState; X, Y: Integer);
  203. begin
  204. edtPW.SetFocus;
  205. end;
  206. procedure TLoginFrm.btnCloseClick(Sender: TObject);
  207. begin
  208. Close;
  209. end;
  210. procedure TLoginFrm.FormDestroy(Sender: TObject);
  211. begin
  212. FUsersCon.Close;
  213. FUsersCon.Free;
  214. FUsersQry.Free;
  215. end;
  216. procedure TLoginFrm.ReadCloudUser;
  217. var s: string;
  218. begin
  219. FUsersCon := TADOConnection.Create(nil);
  220. FUsersCon.LoginPrompt := False;
  221. s := 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=CloudUser.dat;Persist Security Info=False';
  222. FUsersCon.ConnectionString := s;
  223. FUsersQry := TADOQuery.Create(nil);
  224. FUsersQry.Connection := FUsersCon;
  225. FUsersQry.SQL.Text := 'Select Top 15 * From Users Order by LoginTimes Desc';
  226. FUsersQry.Open;
  227. cbUser.Properties.Items.Clear;
  228. if FUsersQry.RecordCount > 0 then
  229. begin
  230. FUsersQry.First;
  231. while not FUsersQry.Eof do
  232. begin
  233. cbUser.Properties.Items.Add(FUsersQry.FieldByName('Account').AsString);
  234. FUsersQry.Next;
  235. end;
  236. end;
  237. FUsersQry.Close;
  238. end;
  239. procedure TLoginFrm.WriteCloudUser;
  240. begin
  241. FUsersQry.Close;
  242. FUsersQry.SQL.Text := Format('Select * From Users where UserID = %d', [PHPWeb.UserID]);
  243. FUsersQry.Open;
  244. if FUsersQry.RecordCount > 0 then
  245. begin
  246. FUsersQry.Close;
  247. FUsersQry.SQL.Text := Format('Update Users Set LoginTimes=LoginTimes+1 where UserID = %d', [PHPWeb.UserID]);
  248. FUsersQry.ExecSQL;
  249. end
  250. else
  251. begin
  252. FUsersQry.Close;
  253. FUsersQry.SQL.Text := Format('Insert into Users(UserID,Account,RealName,LoginTimes) Values(%d,''%s'',''%s'',1)',
  254. [PHPWeb.UserID, PHPWeb.Account, PHPWeb.RealName]);
  255. FUsersQry.ExecSQL;
  256. end;
  257. FUsersQry.Close;
  258. end;
  259. procedure TLoginFrm.cbUserKeyDown(Sender: TObject; var Key: Word;
  260. Shift: TShiftState);
  261. begin
  262. if Key = VK_Return then
  263. begin
  264. edtPW.SetFocus;
  265. edtPW.SelectAll;
  266. end;
  267. end;
  268. procedure TLoginFrm.cbUserClick(Sender: TObject);
  269. // For Test Quickly. chenshilong, 2015-09-30
  270. //const
  271. // AccArr: array[1..11, 1..3] of string = (
  272. // ('1', '2636698008@qq.com', 'smartcost3850887'), // 纵横销售演示服务器
  273. // ('2', '1971614655@qq.com', '357134933..'),
  274. // ('3', '1835082984@qq.com', '123456'),
  275. // ('4', '2417587264@qq.com', 'koukou0708'),
  276. // ('5', '2609827960@qq.com', 'missling'),
  277. // ('6', '1240621850@qq.com', '87654321'),
  278. // ('7', '1014149875@qq.com', 'zhbwoai'),
  279. // ('8', '1525739553@qq.com', '123456'),
  280. // ('9', '1391010261@qq.com', 'missling'),
  281. // ('10', '916960227@qq.com', '123456'),
  282. // ('11', '916960227@qq.com', '12345678') // 测试服务器
  283. // );
  284. //
  285. //var
  286. // i: Integer;
  287. // bEx: Boolean;
  288. begin
  289. // if G_IsTest then
  290. // begin
  291. // bEx := False;
  292. // for i := Low(AccArr) to High(AccArr) do
  293. // begin
  294. // if AccArr[i, 1] = cbUser.Text then
  295. // begin
  296. // cbUser.Text := AccArr[i, 2];
  297. // edtPW.Text := AccArr[i, 3];
  298. // bEx := True;
  299. // Break;
  300. // end;
  301. // end;
  302. // if not bEx then
  303. // begin
  304. // cbUser.Clear;
  305. // edtPW.Clear;
  306. // end;
  307. // end;
  308. end;
  309. procedure TLoginFrm.nClearAccountClick(Sender: TObject);
  310. begin
  311. if Application.MessageBox('确定要清空所有记录的帐户信息吗?', '询问', MB_YESNO + MB_ICONQUESTION) = ID_No then
  312. Exit;
  313. FUsersQry.Close;
  314. FUsersQry.SQL.Text := 'Delete * From Users';
  315. FUsersQry.ExecSQL;
  316. FUsersQry.Close;
  317. cbUser.Properties.Items.Clear;
  318. end;
  319. end.