Программирование

Как распечатать текст из Memo или ListBox

Uses Prints;

procedure PrintStrings(Strings: TStrings);
var
Prn: TextFile;
i: word;
begin
AssignPrn(Prn);
try
    Rewrite(Prn);
    try
      for i := 0 to Strings.Count - 1 do
        writeln(Prn, Strings.Strings[i]);
    finally
      CloseFile(Prn);
    end;
except
    on EInOutError do
      MessageDlg('Error Printing text.', mtError, [mbOk], 0);
end;
end;

Для вызова процедуры печате напишите: PrintStrings(Memo1.Lines) или PrintStrings(Listbox1.Items);

Как проверить правильность введенного Email-a

function IsValidEmail(const Value: string): boolean;
function CheckAllowed(const s: string): boolean;
var
    i: integer;
begin
    Result:= false;
    for i:= 1 to Length(s) do
    begin
      { недопустимый символ в s - значит недопустимый адрес }
      if not (s[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_', '-', '.']) then
        Exit;
    end;
    Result:= true;
end;
var
i: integer;
namePart, serverPart: string;
begin // начало выполнения IsValidEmail
Result:= false;
i:= Pos('@', Value);
if i = 0 then
    Exit;
namePart:= Copy(Value, 1, i - 1);
serverPart:= Copy(Value, i + 1, Length(Value));
// @ не указано имя         имя или сервер не указаны; минимально для сервера. "a.com"
if (Length(namePart) = 0) or ((Length(serverPart) < 5)) then
    Exit;
i:= Pos('.', serverPart);
// должно иметь точку и как минимум три знака от конца
if (i = 0) or (i > (Length(serverPart) - 2)) then
    Exit;
Result:= CheckAllowed(namePart) and CheckAllowed(serverPart);
end;

Как осуществить быстрый поиск в ListBox

Разместите на форму 2 компонента: ListBox и Edit. В событии Change у Edit напишите следующее:

procedure TForm1.Edit1Change(Sender: TObject);
begin
ListBox1.Perform(LB_SELECTSTRING,-1,longint(Pchar(Edit1.text)));
end;

Как запретить запуск второй копии программы

// Способ первый

procedure TForm1.FormCreate(Sender: TObject);
var
Wnd : HWND;
begin
Wnd := CreateMutex( nil, true , PChar( Application.title ) );
if GetLastError = ERROR_ALREADY_EXISTS then
begin
CloseHandle( Wnd );
Application.Terminate;
end;
end;

// Способ второй
procedure TForm1.FormCreate(Sender: TObject);
var
Wnd: hWnd;
buff: array [0..127] of char;
begin
Wnd := GetWindow( Handle, gw_HWndFirst );
while Wnd <> 0 do
begin
// Если не собственное и не дочернее окно
if ( Wnd <> Application.Handle ) and ( GetWindow( Wnd, gw_Owner ) = 0 ) then
begin
GetWindowText( Wnd, buff, sizeof( buff ) );
// Если заголовок совпадает, то...
if StrPas( buff ) = Application.Title then // Поторный запуск
begin
// Действие при повторном запуске
CloseHandle( Wnd );
Application.Terminate;
end;
end;
Wnd := GetWindow( Wnd, gw_hWndNext );
end;
end;

// Способ третий
// Приведите файл *.dpr к следующему виду
program Project1;

uses
Forms, Windows,
Unit1 in 'Unit1.pas' {Form1};

{$R *.res}

var
HWND: THandle;

function Check: boolean;
begin
HWND := OpenMutex( MUTEX_ALL_ACCESS, false, 'MyOwnMutex' );
Result := ( HWND <> 0 );
if HWND = 0 then HWND := CreateMutex( nil, false, 'MyOwnMutex' );
end;

begin
if Check then Exit;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

// Способ четвертый
// Приведите файл *.dpr к следующему виду
program Project1;

uses
Forms, SyncObjs,
Unit1 in 'Unit1.pas' {Form1};

{$R *.res}

var
CheckEvent: TEvent;

begin
CheckEvent:= TEvent.Create( nil, false, true, 'MYPROGRAM_CHECKEXIST' );
if CheckEvent.WaitFor( 10 ) <> wrSignaled then
Exit;

Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

// Способ пятый
// Необходимо быть уверенным, что в системе больше нет окон с именем "TForm1"
// Приведите файл *.dpr к следующему виду
program Project1;

uses
Forms, Windows,
Unit1 in 'Unit1.pas' {Form1};

{$R *.res}

var
hwnd: THandle;

begin
hwnd := FindWindow( 'TForm1', 'Form1' );
if hwnd = 0 then
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end
else
SetForegroundWindow( hwnd );
end.

// Способ шестой
// Приведите файл *.dpr к следующему виду
program Project1;

uses
Forms, Windows,
Unit1 in 'Unit1.pas' {Form1};

{$R *.res}

const
MemFileSize = 127;
MemFileName = 'one_example';

var
MemHnd: HWND;

begin
MemHnd := CreateFileMapping( HWND( $FFFFFFFF ), nil, PAGE_READWRITE,
0, MemFileSize, MemFileName);
if GetLastError <> ERROR_ALREADY_EXISTS then
begin
Application.Initialize;
with TForm1.Create( nil ) do
try
Show;
Update;
Application.CreateForm(TForm1, Form1);
finally
Free;
end;
Application.Run;
end
else
Application.MessageBox( 'Приложение уже запущено',
'Производственно-диспетчерская служба', MB_OK );
CloseHandle( MemHnd );
end.

Как узнать состояние кнопок Caps Lock, Num Lock, Scroll Lock

// Timer1.Interval = 1
procedure TForm1.Timer1Timer(Sender: TObject);
var
KS: TKeyboardState;
begin
GetKeyboardState( KS );
if KS[020] and 1 = 1 then
LabelCapsLock.Enabled := true
else
LabelCapsLock.Enabled := false;
if KS[144] and 1 = 1 then
LabelNumLock.Enabled := true
else
LabelNumLock.Enabled := false;
if KS[145] and 1 = 1 then
LabelScrollLock.Enabled := true
else
LabelScrollLock.Enabled := false;
SetKeyboardState( KS );
end;

1-5 6-6

Программирование на Delphi.

Программирование