Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- unit FormLogin;
- interface
- uses
- Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
- System.Classes, Vcl.Graphics,
- Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls,
- Vcl.ComCtrls, StdStyleActnCtrls;
- type
- TfrmLogin = class(TForm)
- btnExit: TButton;
- edtUsername: TEdit;
- lblLoginT: TLabel;
- shp1: TBevel;
- shp2: TBevel;
- lblUsername: TLabel;
- edtPass: TEdit;
- lblPassword: TLabel;
- lblSignUp: TLabel;
- lblUsernameS: TLabel; // ****** + "S" where S means
- edtUsernameS: TEdit; // the component is for signing up
- edtPassS: TEdit; // not for logging in.
- lblPasswordS: TLabel;
- edtRePassS: TEdit;
- lblRePasswordS: TLabel;
- btnSignUp: TButton;
- btnLogin: TButton;
- lblpassmatch: TLabel;
- lblUserTaken: TLabel;
- lblInvalidLogin: TLabel;
- procedure btnExitClick(Sender: TObject);
- procedure btnSignUpClick(Sender: TObject);
- procedure FormCreate(Sender: TObject);
- procedure edtUsernameSKeyUp(Sender: TObject; var Key: Word;
- Shift: TShiftState);
- procedure edtPassSKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
- procedure edtRePassSKeyUp(Sender: TObject; var Key: Word;
- Shift: TShiftState);
- procedure btnLoginClick(Sender: TObject);
- procedure FormShow(Sender: TObject);
- private
- { Private declarations }
- procedure ClearFields;
- Procedure UpDir(loc: String); overload; // debug version prints location
- // of call to console
- procedure UpDir; overload; // Go up a directory
- public
- { Public declarations }
- AccountNumber: Integer;
- AccountName: String;
- Procedure CheckAndCreateDirectories;
- end;
- type
- TAccountInfo = Record
- AccountName: String[25];
- AccountPass: String[25];
- AccountNumber: Integer;
- end;
- // type TAccountFile = File of TAccountInfo;
- var
- frmLogin: TfrmLogin;
- AccountFile: File of TAccountInfo;
- AccountInfoRecord: TAccountInfo;
- implementation
- {$R *.dfm}
- uses FormMain;
- Procedure TfrmLogin.UpDir(loc: String);
- begin
- writeln(loc + ': ' + GetCurrentDir);
- SetCurrentDir(ExtractFilePath(ExcludeTrailingPathDelimiter(GetCurrentDir)));
- writeln(loc + ': ' + GetCurrentDir);
- end;
- Procedure TfrmLogin.UpDir;
- begin
- SetCurrentDirectory
- (PChar(ExtractFilePath(ExcludeTrailingPathDelimiter(GetCurrentDir))));
- end;
- /// /////////////////////////////////////////////////////////////////////////////
- procedure CheckForAllCompleteFields;
- begin
- if (frmLogin.lblpassmatch.Caption = 'Passwords Match') and
- (frmLogin.edtUsernameS.Text <> '') and (frmLogin.edtPassS.Text <> '') and
- (frmLogin.edtRePassS.Text <> '') and not(frmLogin.lblUserTaken.Visible) then
- frmLogin.btnSignUp.Enabled := True
- else
- frmLogin.btnSignUp.Enabled := false;
- end;
- /// /////////////////////////////////////////////////////////////////////////////
- Procedure CheckIfPasswordsMatch;
- begin
- frmLogin.lblpassmatch.Visible := True;
- frmLogin.lblpassmatch.Font.Color := clred;
- if (frmLogin.edtPassS.Text <> '') and (frmLogin.edtRePassS.Text <> '') then
- begin // IF Start
- if (frmLogin.edtPassS.Text = frmLogin.edtRePassS.Text) then
- begin
- frmLogin.lblpassmatch.Caption := 'Passwords Match';
- frmLogin.lblpassmatch.Font.Color := clgreen;
- end
- else
- begin
- frmLogin.lblpassmatch.Caption := 'Passwords do not Match';
- frmLogin.lblpassmatch.Font.Color := clred;
- frmLogin.btnSignUp.Enabled := false;
- end;
- end; // ENDIF
- end;
- /// /////////////////////////////////////////////////////////////////////////////
- function FindNextAccountNumber(AccountInfo: TAccountInfo): Integer;
- var
- CurrentAccountNum: Integer;
- begin
- SetCurrentDir(GetCurrentDir + '\Main Files');
- AssignFile(AccountFile, 'AccountData.dat');
- Reset(AccountFile);
- while not Eof(AccountFile) do
- begin // while
- read(AccountFile, AccountInfo);
- end; // while
- Closefile(AccountFile);
- Result := AccountInfo.AccountNumber + 1;
- frmLogin.UpDir;
- end;
- /// /////////////////////////////////////////////////////////////////////////////
- procedure ReadNewAccountToFile(AccountInfo: TAccountInfo);
- begin
- SetCurrentDir(GetCurrentDir + '\Main Files');
- AssignFile(AccountFile, 'AccountData.dat');
- Reset(AccountFile);
- Seek(AccountFile, Filesize(AccountFile));
- Write(AccountFile, AccountInfo);
- Closefile(AccountFile);
- frmLogin.UpDir;
- end;
- /// /////////////////////////////////////////////////////////////////////////////
- procedure TfrmLogin.btnExitClick(Sender: TObject);
- begin
- close;
- end;
- /// /////////////////////////////////////////////////////////////////////////////
- Function EncryptPass(Password: String): String;
- var
- Mod1, Count: Integer;
- begin
- Result := '';
- Mod1 := Length(Password);
- for Count := Low(Password) to (Length(Password)) do
- begin
- Result := Result + Chr(Ord(Password[Count]) + Mod1);
- end;
- end;
- /// /////////////////////////////////////////////////////////////////////////////
- Function DecryptPass(EncPassword: String): String;
- var
- Mod1, Count: Integer;
- begin
- Result := '';
- Mod1 := Length(EncPassword);
- for Count := Low(EncPassword) to (Length(EncPassword)) do
- begin
- Result := Result + Chr(Ord(EncPassword[Count]) - Mod1);
- end;
- end;
- /// /////////////////////////////////////////////////////////////////////////////
- Procedure AssignAccountDataS( { Username : String; Password : String; }
- AccountInfo: TAccountInfo);
- begin
- AccountInfo.AccountName := frmLogin.edtUsernameS.Text;
- AccountInfo.AccountPass := frmLogin.edtPassS.Text;
- // AccountInfo.AccountNumber := AccountNum;
- end;
- /// /////////////////////////////////////////////////////////////////////////////
- procedure TfrmLogin.btnLoginClick(Sender: TObject);
- var
- AccountFound: Boolean;
- EncryptedPass: String;
- begin
- EncryptedPass := EncryptPass(edtPass.Text);
- AccountFound := false;
- SetCurrentDir(GetCurrentDir + '\Main Files');
- AssignFile(AccountFile, 'AccountData.dat');
- Reset(AccountFile);
- while not Eof(AccountFile) do
- begin // Start While //iterate through file until account is found
- Read(AccountFile, AccountInfoRecord);
- if (AccountInfoRecord.AccountName = edtUsername.Text) and
- (AccountInfoRecord.AccountPass = EncryptedPass) then
- begin
- // login
- frmLogin.AccountName := AccountInfoRecord.AccountName;
- frmLogin.AccountNumber := AccountInfoRecord.AccountNumber;
- frmLogin.Hide;
- AccountFound := True;
- break;
- end;
- end; // end While
- frmLogin.UpDir; // go back to parent directory
- if AccountFound then
- begin
- frmMain.Show; // Only show after finding account number;
- lblInvalidLogin.Visible := false; // remove it if the user had previous
- // //login attempt
- end
- else
- begin
- lblInvalidLogin.Visible := True;
- end;
- Closefile(AccountFile);
- end;
- /// /////////////////////////////////////////////////////////////////////////////
- procedure CheckIfUserTaken;
- begin
- SetCurrentDir(GetCurrentDir + '\Main Files');
- AssignFile(AccountFile, 'AccountData.dat');
- Reset(AccountFile);
- while not Eof(AccountFile) do
- begin // while
- read(AccountFile, AccountInfoRecord);
- if AccountInfoRecord.AccountName = frmLogin.edtUsernameS.Text then
- begin
- frmLogin.lblUserTaken.Visible := True;
- frmLogin.lblUserTaken.Caption := 'Username already taken';
- frmLogin.lblUserTaken.Font.Color := clred;
- break;
- end
- else
- frmLogin.lblUserTaken.Visible := false;
- end; // while
- Closefile(AccountFile);
- frmLogin.UpDir;
- end;
- procedure TfrmLogin.CheckAndCreateDirectories;
- begin
- if not DirectoryExists('Main Files') then
- CreateDir('Main Files');
- if not DirectoryExists('Flashcards') then
- CreateDir('Flashcards');
- if not DirectoryExists('Topic Tabs') then
- CreateDir('Topic Tabs');
- if not DirectoryExists('Notepads') then
- CreateDir('Notepads');
- if not DirectoryExists('Public Flashcards') then
- CreateDir('Public Flashcards');
- end;
- procedure TfrmLogin.btnSignUpClick(Sender: TObject);
- begin
- AssignAccountDataS(AccountInfoRecord);
- CheckIfUserTaken;
- CheckForAllCompleteFields;
- if btnSignUp.Enabled then
- begin
- AccountInfoRecord.AccountName := frmLogin.edtUsernameS.Text;
- AccountInfoRecord.AccountPass := EncryptPass(frmLogin.edtPassS.Text);
- AccountInfoRecord.AccountNumber := FindNextAccountNumber(AccountInfoRecord);
- ReadNewAccountToFile(AccountInfoRecord);
- frmLogin.AccountName := AccountInfoRecord.AccountName;
- frmLogin.AccountNumber := AccountInfoRecord.AccountNumber;
- frmMain.Show;
- frmLogin.ClearFields;
- end
- end;
- /// //////////Begin checks on user-entered data////////////////////
- procedure TfrmLogin.edtPassSKeyUp(Sender: TObject; var Key: Word;
- Shift: TShiftState);
- begin
- CheckIfPasswordsMatch;
- CheckForAllCompleteFields;
- end;
- procedure TfrmLogin.edtRePassSKeyUp(Sender: TObject; var Key: Word;
- Shift: TShiftState);
- begin
- CheckIfPasswordsMatch;
- CheckForAllCompleteFields;
- end;
- procedure TfrmLogin.edtUsernameSKeyUp(Sender: TObject; var Key: Word;
- Shift: TShiftState);
- begin
- CheckForAllCompleteFields;
- lblUserTaken.Visible := false;
- end;
- /// /////////End Checks//////////////////////////////////////////////
- procedure TfrmLogin.FormCreate(Sender: TObject);
- begin
- frmLogin.Height := Screen.WorkAreaHeight;
- frmLogin.Width := Screen.WorkAreaWidth;
- frmLogin.CheckAndCreateDirectories;
- /// //////////
- SetCurrentDir(GetCurrentDir + '\Main Files');
- {$I-}
- AssignFile(AccountFile, 'AccountData.dat');
- Reset(AccountFile);
- Closefile(AccountFile);
- {$I+}
- frmLogin.UpDir; // check to see if an old file exists
- if (IOResult <> 0) then // already
- begin
- SetCurrentDir(GetCurrentDir + '\Main Files');
- Rewrite(AccountFile);
- Closefile(AccountFile); // Create a new file for writing to
- frmLogin.UpDir;
- end;
- /// ////////
- // if (Screen.Width <> 1920) and (Screen.Height <> 1080) then
- frmLogin.VertScrollBar.Position := frmLogin.VertScrollBar.Range.MinValue;
- // this doesn't currently appear to work
- lblpassmatch.Visible := false;
- lblInvalidLogin.Visible := false;
- lblpassmatch.Caption := 'Passwords do not match';
- lblpassmatch.Font.Color := clred;
- btnSignUp.Enabled := false;
- lblUserTaken.Visible := false;
- end;
- procedure TfrmLogin.FormShow(Sender: TObject);
- begin
- frmLogin.ClearFields;
- end;
- procedure TfrmLogin.ClearFields; // Clears all edit boxes and labels
- begin
- frmLogin.edtPass.Clear;
- frmLogin.edtPassS.Clear;
- frmLogin.edtRePassS.Clear;
- frmLogin.edtUsername.Clear;
- frmLogin.edtUsernameS.Clear;
- frmLogin.lblpassmatch.Visible := false;
- frmLogin.lblUserTaken.Visible := false;
- frmLogin.lblInvalidLogin.Visible := false;
- end;
- end.
Add Comment
Please, Sign In to add comment