Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
выпущен 10 декабря!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Отправлять электронную почту

Приходит хакер к психиатру:
- Док, помоги, у меня раздвоение виртуальной личности.
- Не понял, это как?
- Я со своего второго ника на третий E-Mailы начал получать.

В D5 Вы можете попробовать использовать компоненты TNMSMTP и TNMPOP3,

в D6 и Kylix компоненты от NetMasters заменены компонентами Indy.

Алгоритм простой (для сторонних компонентов он принципиально ничем не отличается):

  • необходимо заполнить структуру PostMessage;
  • отправить эту структуру при помощи метода SendMail.

Структура PostMessage:

  • (*) FromName: string - имя отправителя;
  • FromAddress: string - Почтовый адресс отправителя
  • ReplyToAddress: string - Адрес, по которому следует ответить на письмо;
  • Organization: string
  • LocalProgram: string - Имя почтовой программы отправителя;
  • (*) ToAddress: TStringList - Почтовый адрес главного получателя (ей)
  • ToCC: TStringList - Список получателей Carbon Copy
  • ToBCC: TSringList - Список получателей Blind Carbon Copy
  • Attachments: TStringList - Список вложений
  • Body: TStringList - Собственно текст письма
  • Subject: string - Строка темы письма.

(*) - помечены обязательные поля. С остальным не сложно разобраться самому.

Также это можно сделать при помощи MAPI.

Т.е. письмо будет отправлено средствами _почтовой_программы_по_умолчанию_ - со всеми недостатками :) (например письмо будет помещено в папку "отправленные"). Зато без всяких там компонент и просто :)

Hиже готовая функция, в которой:

  • From - от кого
  • Dest - кому
  • Subject - тема
  • Text - текст письма
  • FileName - путь к вложению (если '', то соответственно ничего и не вкладываем)
  • Outlook - показывать или нет письмо перед отправкой (в твоём случае False)

 Uses MAPI;
 ...
 
 function SendMail(const From, Dest, Subject, Text, FileName: PChar;
 Outlook: boolean):Integer;
 var
   Message: TMapiMessage;
   Recipient, Sender: TMapiRecipDesc;
   File_Attachment: TMapiFileDesc;
 
   function MakeMessage: TMapiMessage;
   begin
     FillChar(Sender, SizeOf(Sender), 0);
     Sender.ulRecipClass := MAPI_ORIG;
     Sender.lpszAddress := From;
 
     FillChar(Recipient, SizeOf(Recipient), 0);
     Recipient.ulRecipClass := MAPI_TO;
     Recipient.lpszAddress := Dest;
 
     FillChar(File_Attachment, SizeOf(File_Attachment), 0);
     File_Attachment.nPosition := Cardinal(-1);
     File_Attachment.lpszPathName := FileName;
 
     FillChar(Result, SizeOf(Result), 0);
     with Message do begin
       lpszSubject := Subject;
       lpszNoteText := Text;
       lpOriginator := @Sender;
       nRecipCount := 1;
       lpRecips := @Recipient;
       nFileCount := 1;
       lpFiles := @File_Attachment;
     end;
   end;
 
 var
   SM: TFNMapiSendMail;
   MAPIModule: HModule;
   MAPI_FLAG: Cardinal;
 begin
   if Outlook then
    MAPI_FLAG:=MAPI_DIALOG
   else
    MAPI_FLAG:=0;
   MAPIModule := LoadLibrary(PChar(MAPIDLL));
   if MAPIModule = 0 then
     Result := -1
   else
     try
       @SM := GetProcAddress(MAPIModule, 'MAPISendMail');
       if @SM <> nil then begin
         MakeMessage;
         Result := SM(0, Application.Handle, Message, MAPI_FLAG, 0);
       end else Result := 1;
     finally
       FreeLibrary(MAPIModule);
     end;
 end;
 
 




Отправка E-mail через MAPI


Автор: Eugene Mayevski


 unit MapiControl;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs;
 
 type
   { Вводим новый тип события для получения Errorcode }
   TMapiErrEvent = procedure(Sender: TObject; ErrCode: Integer) of object;
 
   TMapiControl = class(TComponent)
       constructor Create(AOwner: TComponent); override;
       destructor Destroy; override;
     private
     { Private-объявления }
     FSubject: string;
     FMailtext: string;
     FFromName: string;
     FFromAdress: string;
     FTOAdr: TStrings;
     FCCAdr: TStrings;
     FBCCAdr: TStrings;
     FAttachedFileName: TStrings;
     FDisplayFileName: TStrings;
     FShowDialog: Boolean;
     FUseAppHandle: Boolean;
     { Error Events: }
     FOnUserAbort: TNotifyEvent;
     FOnMapiError: TMapiErrEvent;
     FOnSuccess: TNotifyEvent;
     { +> Изменения, внесённые Eugene Mayevski [mailto:Mayevski@eldos.org]}
     procedure SetToAddr(newValue : TStrings);
     procedure SetCCAddr(newValue : TStrings);
     procedure SetBCCAddr(newValue : TStrings);
     procedure SetAttachedFileName(newValue : TStrings);
     { +< конец изменений }
   protected
     { Protected-объявления }
   public
     { Public-объявления }
     ApplicationHandle: THandle;
     procedure Sendmail();
     procedure Reset();
   published
     { Published-объявления }
     property Subject: string read FSubject write FSubject;
     property Body: string read FMailText write FMailText;
     property FromName: string read FFromName write FFromName;
     property FromAdress: string read FFromAdress write FFromAdress;
     property Recipients: TStrings read FTOAdr write SetTOAddr;
     property CopyTo: TStrings read FCCAdr write SetCCAddr;
     property BlindCopyTo: TStrings read FBCCAdr write SetBCCAddr;
     property AttachedFiles: TStrings read FAttachedFileName write SetAttachedFileName;
     property DisplayFileName: TStrings read FDisplayFileName;
     property ShowDialog: Boolean read FShowDialog write FShowDialog;
     property UseAppHandle: Boolean read FUseAppHandle write FUseAppHandle;
 
     { события: }
     property OnUserAbort: TNotifyEvent read FOnUserAbort write FOnUserAbort;
     property OnMapiError: TMapiErrEvent read FOnMapiError write FOnMapiError;
     property OnSuccess: TNotifyEvent read FOnSuccess write FOnSuccess;
 end;
 
 procedure register;
 
 implementation
 
 uses Mapi;
 
 { регистрируем компонент: }
 procedure register;
 begin
   RegisterComponents('expectIT', [TMapiControl]);
 end;
 
 { TMapiControl }
 
 constructor TMapiControl.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
   FOnUserAbort := nil;
   FOnMapiError := nil;
   FOnSuccess := nil;
   FSubject := '';
   FMailtext := '';
   FFromName := '';
   FFromAdress := '';
   FTOAdr := TStringList.Create;
   FCCAdr := TStringList.Create;
   FBCCAdr := TStringList.Create;
   FAttachedFileName := TStringList.Create;
   FDisplayFileName := TStringList.Create;
   FShowDialog := False;
   ApplicationHandle := Application.Handle;
 end;
 
 { +> Изменения, внесённые Eugene Mayevski [mailto:Mayevski@eldos.org]}
 procedure TMapiControl.SetToAddr(newValue : TStrings);
 begin
   FToAdr.Assign(newValue);
 end;
 
 procedure TMapiControl.SetCCAddr(newValue : TStrings);
 begin
   FCCAdr.Assign(newValue);
 end;
 
 procedure TMapiControl.SetBCCAddr(newValue : TStrings);
 begin
   FBCCAdr.Assign(newValue);
 end;
 
 procedure TMapiControl.SetAttachedFileName(newValue : TStrings);
 begin
   FAttachedFileName.Assign(newValue);
 end;
 { +< конец изменений }
 
 destructor TMapiControl.Destroy;
 begin
   FTOAdr.Free;
   FCCAdr.Free;
   FBCCAdr.Free;
   FAttachedFileName.Free;
   FDisplayFileName.Free;
   inherited destroy;
 end;
 
 { Сбрасываем все используемые поля}
 procedure TMapiControl.Reset;
 begin
   FSubject := '';
   FMailtext := '';
   FFromName := '';
   FFromAdress := '';
   FTOAdr.Clear;
   FCCAdr.Clear;
   FBCCAdr.Clear;
   FAttachedFileName.Clear;
   FDisplayFileName.Clear;
 end;
 
 { Эта процедура составляет и отправляет Email }
 procedure TMapiControl.Sendmail;
 var
   MapiMessage: TMapiMessage;
   MError: Cardinal;
   Sender: TMapiRecipDesc;
   PRecip, Recipients: PMapiRecipDesc;
   PFiles, Attachments: PMapiFileDesc;
   i: Integer;
   AppHandle: THandle;
 begin
   { Перво-наперво сохраняем Handle приложения, if not
   the Component might fail to send the Email or
   your calling Program gets locked up. }
   AppHandle := Application.Handle;
 
   { Нам нужно зарезервировать память для всех получателей }
   MapiMessage.nRecipCount := FTOAdr.Count + FCCAdr.Count + FBCCAdr.Count;
   GetMem(Recipients, MapiMessage.nRecipCount * sizeof(TMapiRecipDesc));
 
   try
     with MapiMessage do
     begin
       ulReserved := 0;
       { Устанавливаем поле Subject: }
       lpszSubject := PChar(Self.FSubject);
 
       { ... Body: }
       lpszNoteText := PChar(FMailText);
 
       lpszMessageType := nil;
       lpszDateReceived := nil;
       lpszConversationID := nil;
       flFlags := 0;
 
       { и отправителя: (MAPI_ORIG) }
       Sender.ulReserved := 0;
       Sender.ulRecipClass := MAPI_ORIG;
       Sender.lpszName := PChar(FromName);
       Sender.lpszAddress := PChar(FromAdress);
       Sender.ulEIDSize := 0;
       Sender.lpEntryID := nil;
       lpOriginator := @Sender;
 
       PRecip := Recipients;
 
       { У нас много получателей письма: (MAPI_TO)
       установим для каждого: }
       if nRecipCount > 0 then
       begin
         for i := 1 to FTOAdr.Count do
         begin
           PRecip^.ulReserved := 0;
           PRecip^.ulRecipClass := MAPI_TO;
           { lpszName should carry the Name like in the
           contacts or the adress book, I will take the
           email adress to keep it short: }
           PRecip^.lpszName := PChar(FTOAdr.Strings[i - 1]);
           { Если Вы используете этот компонент совместно с Outlook97 или 2000
           (не Express версии) , то Вам прийдётся добавить
           'SMTP:' в начало каждого (email-) адреса.
           }
           PRecip^.lpszAddress := PChar('SMTP:' + FTOAdr.Strings[i - 1]);
           PRecip^.ulEIDSize := 0;
           PRecip^.lpEntryID := nil;
           Inc(PRecip);
         end;
 
         { То же самое проделываем с получателями копии письма: (CC, MAPI_CC) }
         for i := 1 to FCCAdr.Count do
         begin
           PRecip^.ulReserved := 0;
           PRecip^.ulRecipClass := MAPI_CC;
           PRecip^.lpszName := PChar(FCCAdr.Strings[i - 1]);
           PRecip^.lpszAddress := PChar('SMTP:' + FCCAdr.Strings[i - 1]);
           PRecip^.ulEIDSize := 0;
           PRecip^.lpEntryID := nil;
           Inc(PRecip);
         end;
 
         { ... тоже самое для Bcc: (BCC, MAPI_BCC) }
         for i := 1 to FBCCAdr.Count do
         begin
           PRecip^.ulReserved := 0;
           PRecip^.ulRecipClass := MAPI_BCC;
           PRecip^.lpszName := PChar(FBCCAdr.Strings[i - 1]);
           PRecip^.lpszAddress := PChar('SMTP:' + FBCCAdr.Strings[i - 1]);
           PRecip^.ulEIDSize := 0;
           PRecip^.lpEntryID := nil;
           Inc(PRecip);
         end;
       end;
       lpRecips := Recipients;
 
       { Теперь обработаем прикреплённые к письму файлы: }
 
       if FAttachedFileName.Count > 0 then
       begin
         nFileCount := FAttachedFileName.Count;
         GetMem(Attachments, MapiMessage.nFileCount * sizeof(TMapiFileDesc));
 
         PFiles := Attachments;
 
         { Во первых установим отображаемые на экране имена файлов (без пути): }
         FDisplayFileName.Clear;
         for i := 0 to FAttachedFileName.Count - 1 do
           FDisplayFileName.Add(ExtractFileName(FAttachedFileName[i]));
 
         if nFileCount > 0 then
         begin
           { Теперь составим структурку для прикреплённого файла: }
           for i := 1 to FAttachedFileName.Count do
           begin
             { Устанавливаем полный путь }
             Attachments^.lpszPathName := PChar(FAttachedFileName.Strings[i - 1]);
             { ... и имя, отображаемое на дисплее: }
             Attachments^.lpszFileName := PChar(FDisplayFileName.Strings[i - 1]);
             Attachments^.ulReserved := 0;
             Attachments^.flFlags := 0;
             { Положение должно быть -1, за разьяснениями обращайтесь в WinApi Help. }
             Attachments^.nPosition := Cardinal(-1);
             Attachments^.lpFileType := nil;
             Inc(Attachments);
           end;
         end;
         lpFiles := PFiles;
       end
       else
       begin
         nFileCount := 0;
         lpFiles := nil;
       end;
     end;
 
     {
     Send the Mail, silent or verbose:
     Verbose means in Express a Mail is composed and shown as setup.
     In non-Express versions we show the Login-Dialog for a new
     session and after we have choosen the profile to use, the
     composed email is shown before sending
 
     Silent does currently not work for non-Express version. We have
     no Session, no Login Dialog so the system refuses to compose a
     new email. In Express Versions the email is sent in the
     background.
     }
     if FShowDialog then
       MError := MapiSendMail(0, AppHandle, MapiMessage, MAPI_DIALOG
       or MAPI_LOGON_UI or MAPI_NEW_SESSION, 0)
     else
       MError := MapiSendMail(0, AppHandle, MapiMessage, 0, 0);
 
     {
     Теперь обработаем сообщения об ошибках. В MAPI их присутствует достаточное.
     количество. В этом примере я обрабатываю только два из них: USER_ABORT и SUCCESS,
     относящиеся к специальным.
 
     Сообщения, не относящиеся к специальным:
     MAPI_E_AMBIGUOUS_RECIPIENT,
     MAPI_E_ATTACHMENT_NOT_FOUND,
     MAPI_E_ATTACHMENT_OPEN_FAILURE,
     MAPI_E_BAD_RECIPTYPE,
     MAPI_E_FAILURE,
     MAPI_E_INSUFFICIENT_MEMORY,
     MAPI_E_LOGIN_FAILURE,
     MAPI_E_TEXT_TOO_LARGE,
     MAPI_E_TOO_MANY_FILES,
     MAPI_E_TOO_MANY_RECIPIENTS,
     MAPI_E_UNKNOWN_RECIPIENT:
     }
 
     case MError of
       MAPI_E_USER_ABORT:
       begin
         if Assigned(FOnUserAbort) then
           FOnUserAbort(Self);
       end;
       SUCCESS_SUCCESS:
       begin
         if Assigned(FOnSuccess) then
           FOnSuccess(Self);
       end
       else
       begin
         if Assigned(FOnMapiError) then
           FOnMapiError(Self, MError);
       end;
     end;
   finally
     { В заключение освобождаем память }
     FreeMem(Recipients, MapiMessage.nRecipCount * sizeof(TMapiRecipDesc));
   end;
 end;
 { Вопросы и замечания присылайте Автору. }
 end.
 




Передать файл через Socket соединение


- Ну, ты молодец! Вчера сделал больше чем за целый месяц!!
- Да просто у меня Интернет не работал!

Для данной цели можно воспользоваться компонентами TNMStrmServ и TNMStrm, которые предназначены для обмена потоками данных.

Обработчик для клиента:


 var
   MyStream: TMemoryStream;
 begin
   MyStream := TMemoryStream.Create;
   MyStream.LoadFromFile('c:\windows\рабочий стол\DelphiWorld.txt');
   NMStrm1.PostIt(MyStream);
   MyStream.Free;
 end;
 

Обработчик для сервера:


 procedure TForm1.NMStrmServ1MSG(Sender: TComponent;
 const sFrom: string; strm: TStream);
 var
   MyStream: TMemoryStream;
 begin
   MyStream := TMemoryStream.Create;
   MyStream.CopyFrom(strm, NMStrmServ1.BytesTotal);
   MyStream.SaveToFile('c:\windows\рабочий стол\DelphiWorld2.txt');
 end;
 




Переслать файл в Корзину


- С 25 - Ранен.
- С 26 - Ранен.
- С 27 - Файл win. com на диске С: убит!

Сначала нужно в директиве uses подключить модуль ShellAPI, чтобы мы смогли воспользоваться API-функцией SHFileOperation(). А затем уже можно использовать такой вот процедурой:


 procedure SendToPomoyka(FileName: string);
 var
   SHF: TSHFileOpStruct;
 begin
   with SHF do
   begin
     Wnd := Application.Handle;
     wFunc := FO_DELETE;
     pFrom := PChar(FileName);
     fFlags := FOF_SILENT or FOF_ALLOWUNDO;
   end;
   SHFileOperation(SHF);
 end;
 




Как передать фокус следующему контролу


 Perform(WM_NEXTDLGCTL, 0, 0);
 




Отправить сообщение на ICQ

Обменяю 7-значный UIN ICQ на два 6-значных.


 {
   You need 3 TEdits, 1 TMemo und 1 TClientSocket.
   Set the  TClientsocket's Port to 80 and the Host to wwp.mirabilis.com.
 }
 
 var
   Form1: TForm1;
   csend: string;
 
 implementation
 
 {$R *.dfm}
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   cSend := 'POST http://wwp.icq.com/scripts/WWPMsg.dll HTTP/2.0' + chr(13) + chr(10);
   cSend := cSend + 'Referer: http://wwp.mirabilis.com' + chr(13) + chr(10);
   cSend := cSend + 'User-Agent: Mozilla/4.06 (Win95; I)' + chr(13) + chr(10);
   cSend := cSend + 'Connection: Keep-Alive' + chr(13) + chr(10);
   cSend := cSend + 'Host: wwp.mirabilis.com:80' + chr(13) + chr(10);
   cSend := cSend + 'Content-type: application/x-www-form-urlencoded' + chr(13) + chr(10);
   cSend := cSend + 'Content-length:8000' + chr(13) + chr(10);
   cSend := cSend + 'Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, */*' +
     chr(13) + chr(10) + chr(13) + chr(10);
   cSend := cSend + 'from=' + edit1.Text + ' &fromemail=' + edit2.Text +
     ' &fromicq:110206786' + ' &body=' + memo1.Text + ' &to=' + edit3.Text + '&Send=';
   clientsocket1.Active := True;
 end;
 
 procedure TForm1.ClientSocket1Connect(Sender: TObject;
   Socket: TCustomWinSocket);
 begin
   clientsocket1.Socket.SendText(csend);
   clientsocket1.Active := False;
 end;
 




Посылка кода клавиши или текста в окно


 unit Unit1;
 
 interface
 
 uses
 
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 
 type
 
   TForm1 = class(TForm)
     Button1: TButton;
     Button2: TButton;
     procedure Button1Click(Sender: TObject);
     procedure Button2Click(Sender: TObject);
     procedure FormKeyPress(Sender: TObject; var Key: Char);
   private
     AppInst: THandle;
     AppWind: THandle;
   public
     { Public declarations }
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 uses ShellAPI;
 
 procedure SendShift(H: HWnd; Down: Boolean);
 var
   vKey, ScanCode, wParam: Word;
 
   lParam: longint;
 begin
 
   vKey := $10;
   ScanCode := MapVirtualKey(vKey, 0);
   wParam := vKey or ScanCode shl 8;
   lParam := longint(ScanCode) shl 16 or 1;
   if not (Down) then
     lParam := lParam or $C0000000;
   SendMessage(H, WM_KEYDOWN, vKey, lParam);
 end;
 
 procedure SendCtrl(H: HWnd; Down: Boolean);
 var
   vKey, ScanCode, wParam: Word;
 
   lParam: longint;
 begin
 
   vKey := $11;
   ScanCode := MapVirtualKey(vKey, 0);
   wParam := vKey or ScanCode shl 8;
   lParam := longint(ScanCode) shl 16 or 1;
   if not (Down) then
     lParam := lParam or $C0000000;
   SendMessage(H, WM_KEYDOWN, vKey, lParam);
 end;
 
 procedure SendKey(H: Hwnd; Key: char);
 var
   vKey, ScanCode, wParam: Word;
 
   lParam, ConvKey: longint;
   Shift, Ctrl: boolean;
 begin
 
   ConvKey := OemKeyScan(ord(Key));
   Shift := (ConvKey and $00020000) <> 0;
   Ctrl := (ConvKey and $00040000) <> 0;
   ScanCode := ConvKey and $000000FF or $FF00;
   vKey := ord(Key);
   wParam := vKey;
   lParam := longint(ScanCode) shl 16 or 1;
   if Shift then
     SendShift(H, true);
   if Ctrl then
     SendCtrl(H, true);
   SendMessage(H, WM_KEYDOWN, vKey, lParam);
   SendMessage(H, WM_CHAR, vKey, lParam);
   lParam := lParam or $C0000000;
   SendMessage(H, WM_KEYUP, vKey, lParam);
   if Shift then
     SendShift(H, false);
   if Ctrl then
     SendCtrl(H, false);
 end;
 
 function EnumFunc(Handle: HWnd; TF: TForm1): Bool; far;
 begin
 
   TF.AppWind := 0;
   if GetWindowWord(Handle, GWW_HINSTANCE) = TF.AppInst then
     TF.AppWind := Handle;
   result := (TF.AppWind = 0);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   Text: array[0..255] of char;
 begin
 
   AppInst := ShellExecute(Handle, 'open', 'notepad.exe', nil, '', SW_NORMAL);
   EnumWindows(@EnumFunc, longint(self));
   AppWind := GetWindow(AppWind, GW_CHILD);
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
 
   SendKey(AppWind, 'T');
   SendKey(AppWind, 'e');
   SendKey(AppWind, 's');
   SendKey(AppWind, 't');
 end;
 
 procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
 begin
 
   if AppWind <> 0 then
     SendKey(AppWind, Key);
 end;
 
 end.
 




Как посылать нажатие клавиш в элемент управления


Фирма Microsoft выпустила "Windows for woman" Основное отличие продукта в том, что две кнопки- "Yes" и "No" заменены одной- "Maybe..."

Ниже приведена процедура, позволяющаю отправлять нажатия в любой элемент управления (window control), способный принимать ввод с клавиатуры. Вы можете использовать эту технику чтобы включать клавиши NumLock, CapsLock и ScrollLock под Windows NT. Та же техника работает и под Windows 95 для CapsLock и ScrollLock но не работает для клавиши NumLock.

Обратите внимание, что приведены четыре поцедуры: SimulateKeyDown() - эмулировать нажатие клавиши (без отпускания) SimulateKeyUp() - эмулировать отпускание клавиши SimulateKeystroke() - эмулировать удар по клавише (нажатие и отпускание) и SendKeys(), позволяющие Вам гибко контролировать посылаемые сообщения клавиатуры.

SimulateKeyDown(), SimulateKeyUp() и SimulateKeystroke() получают коды виртуальных клавиш (virtural key) (вроде VK_F1). Процедура SimulateKeystroke() получает дополнительный параметр, полезный при эмуляции нажатия PrintScreen. Когда этот параметр равен нулю весь экран будет скопирован в буфер обмена (clipboard). Если дополнительный параметр равен 1 будет скопированно только активное окно.

Четыре метода "button click" демонстрируют использование: ButtonClick1 - включает capslock ButtonClick2 - перехватывает весь экран в буфер обмена (clipboard). ButtonClick3 - перехватывает активное окно в буфер обмена (clipboard). ButtonClick4 - устанавливает фокус в Edit и отправляет в него строку.


 procedure SimulateKeyDown(Key: byte);
 begin
   keybd_event(Key, 0, 0, 0);
 end;
 
 procedure SimulateKeyUp(Key: byte);
 begin
   keybd_event(Key, 0, KEYEVENTF_KEYUP, 0);
 end;
 
 procedure SimulateKeystroke(Key: byte; extra: DWORD);
 begin
   keybd_event(Key, extra, 0, 0);
   keybd_event(Key, extra, KEYEVENTF_KEYUP, 0);
 end;
 
 procedure SendKeys(s: string);
 var
   i: integer;
   flag: bool;
   w: word;
 begin
   {Get the state of the caps lock key}
   flag := not GetKeyState(VK_CAPITAL) and 1 = 0;
   {If the caps lock key is on then turn it off}
   if flag then
     SimulateKeystroke(VK_CAPITAL, 0);
   for i := 1 to Length(s) do
   begin
     w := VkKeyScan(s[i]);
     {If there is not an error in the key translation}
     if ((HiByte(w) $FF) and (LoByte(w) $FF)) then
     begin
       {If the key requires the shift key down - hold it down}
       if HiByte(w) and 1 = 1 then
         SimulateKeyDown(VK_SHIFT);
       {Send the VK_KEY}
       SimulateKeystroke(LoByte(w), 0);
       {If the key required the shift key down - release it}
       if HiByte(w) and 1 = 1 then
         SimulateKeyUp(VK_SHIFT);
     end;
   end;
   {if the caps lock key was on at start, turn it back on}
   if flag then
     SimulateKeystroke(VK_CAPITAL, 0);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   {Toggle the cap lock}
   SimulateKeystroke(VK_CAPITAL, 0);
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   {Capture the entire screen to the clipboard}
   {by simulating pressing the PrintScreen key}
   SimulateKeystroke(VK_SNAPSHOT, 0);
 end;
 
 procedure TForm1.Button3Click(Sender: TObject);
 begin
   {Capture the active window to the clipboard}
   {by simulating pressing the PrintScreen key}
   SimulateKeystroke(VK_SNAPSHOT, 1);
 end;
 
 procedure TForm1.Button4Click(Sender: TObject);
 begin
   {Set the focus to a window (edit control) and send it a string}
   Application.ProcessMessages;
   Edit1.SetFocus;
   SendKeys('Delphi World is REALY BEST');
 end;
 




Отправление сообщения сразу всем элементам управления формы

Вы слишком много работаете за компьютером, если:
- Вспоминаете про антивирусные пакеты всякий раз, когда открываете консервы, книги, двери
- Вспоминаете про архивирование, когда:
- идете с тяжелыми сумками домой
- несете свою жену на руках
- Вспоминаете операцию "удалить", когда: - видите тещу
- инспектора ГИБДД
- Подсознательно ненавидите женщин с именами
- Ася
- Клава
- Вспоминаете про разархивирование, когда получаете зарплату.
Вы слишком мало работаете за компьютером, если:
- позволяете себе заниматься сексом без предохранения, даже с надежным партнером
- позволяете себе заниматься сексом
- позволяете себе.

Можно использовать


 Screen.Forms[i].BroadCast(msg);
 

где [i] - индекс той формы, которой Вы хотите переслать сообщение. BroadCast работает со всеми компонентами, потомками TWinControls и отправляет сообщение всем дочерним компонентам из массива Controls. Если один из дочерних компонентов обрабатывает это сообщение и устанавливает Msg.Result в ненулевое значение - дальнейшая рассылка сообщения останавливается.




Посылка Raw IP-пакетов

Автор: E.J.Molendijk

Дочь пpосит И-нетчика:
- Папа, посмотpи пожалyйста, какая на yлице погода.
- Сейчас,-ответил тот и набpал в бpаyзеpе "http://weather.cnn.com".

Используя данный исходник можно конструировать собственные пакеты содержащие внутри всё, что угодно. Можно самостоятельно указывать в пакете IP-адрес получателя и отправителя, порт назначения и т.д. Если Вы не знаете, что это такое, то лучше не эксперементировать. Единственный недостаток, то, что скорее всего данный пример будет работать только в Windows 2000. Так же исходник позволяет произвести SYN flood и IP spoofing.

Необходимо зайти в систему под Администратором.


 {
 Raw Packet Sender
 using: Delphi + Winsock 2
 
 Copyright (c) 2000 by E.J.Molendijk (xes@dds.nl)
 
 ------------------------------------------------
 Перед использованием измените значения
 SrcIP+SrcPort+DestIP+DestPort на нужные!
 ------------------------------------------------
 }
 unit main;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, OleCtrls, Registry;
 
 const
   SrcIP = '123.123.123.1';
   SrcPort = 1234;
   DestIP = '123.123.123.2';
   DestPort = 4321;
 
   Max_Message = 4068;
   Max_Packet = 4096;
 
 type
 
   TPacketBuffer = array[0..Max_Packet-1] of byte;
 
   TForm1 = class(TForm)
     Button1: TButton;
     Memo1: TMemo;
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
     procedure SendIt;
 end;
 
 // Заголовок IP пакета
 type
   T_IP_Header = record
     ip_verlen : Byte;
     ip_tos : Byte;
     ip_totallength : Word;
     ip_id : Word;
     ip_offset : Word;
     ip_ttl : Byte;
     ip_protocol : Byte;
     ip_checksum : Word;
     ip_srcaddr : LongWord;
     ip_destaddr : LongWord;
 end;
 
 // Заголовок UDP пакета
 type
   T_UDP_Header = record
     src_portno : Word;
     dst_portno : Word;
     udp_length : Word;
     udp_checksum : Word;
 end;
 
 // Некоторые объявления типов для Winsock 2
 u_char = Char;
 u_short = Word;
 u_int = Integer;
 u_long = Longint;
 
 SunB = packed record
   s_b1, s_b2, s_b3, s_b4: u_char;
 end;
 
 SunW = packed record
   s_w1, s_w2: u_short;
 end;
 
 in_addr = record
   case integer of
     0: (S_un_b: SunB);
     1: (S_un_w: SunW);
     2: (S_addr: u_long);
   end;
   TInAddr = in_addr;
 
 Sockaddr_in = record
   case Integer of
     0: (sin_family: u_short;
     sin_port: u_short;
     sin_addr: TInAddr;
     sin_zero: array[0..7] of Char);
     1: (sa_family: u_short;
     sa_data: array[0..13] of Char)
   end;
 
 TSockAddr = Sockaddr_in;
 TSocket = u_int;
 
 const
   WSADESCRIPTION_LEN = 256;
   WSASYS_STATUS_LEN = 128;
 
 type
   PWSAData = ^TWSAData;
   WSAData = record // !!! also WSDATA
     wVersion: Word;
     wHighVersion: Word;
     szDescription: array[0..WSADESCRIPTION_LEN] of Char;
     szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char;
     iMaxSockets: Word;
     iMaxUdpDg: Word;
     lpVendorInfo: PChar;
 end;
 TWSAData = WSAData;
 
 // Определяем необходимые функции winsock 2
 function closesocket(s: TSocket): Integer; stdcall;
 function socket(af, Struct, protocol: Integer): TSocket; stdcall;
 function sendto(s: TSocket; var Buf; len, flags: Integer; var addrto: TSockAddr;
 tolen: Integer): Integer; stdcall;{}
 function setsockopt(s: TSocket; level, optname: Integer; optval: PChar;
 optlen: Integer): Integer; stdcall;
 function inet_addr(cp: PChar): u_long; stdcall; {PInAddr;} { TInAddr }
 function htons(hostshort: u_short): u_short; stdcall;
 function WSAGetLastError: Integer; stdcall;
 function WSAStartup(wVersionRequired: word; var WSData: TWSAData): Integer; stdcall;
 function WSACleanup: Integer; stdcall;
 
 const
   AF_INET = 2; // internetwork: UDP, TCP, etc.
   IP_HDRINCL = 2; // включаем заголовок IP пакета
   SOCK_RAW = 3; // интерфейс raw-протокола
 
   IPPROTO_IP = 0; // dummy for IP
   IPPROTO_TCP = 6; // tcp
   IPPROTO_UDP = 17; // user datagram protocol
   IPPROTO_RAW = 255; // raw IP пакет
 
   INVALID_SOCKET = TSocket(not(0));
   SOCKET_ERROR = -1;
 
 var
   Form1: TForm1;
 
 implementation
 
 // Импортируем функции Winsock 2
 const WinSocket = 'WS2_32.DLL';
 
 function closesocket; external winsocket name 'closesocket';
 function socket; external winsocket name 'socket';
 function sendto; external winsocket name 'sendto';
 function setsockopt; external winsocket name 'setsockopt';
 function inet_addr; external winsocket name 'inet_addr';
 function htons; external winsocket name 'htons';
 function WSAGetLastError; external winsocket name 'WSAGetLastError';
 function WSAStartup; external winsocket name 'WSAStartup';
 function WSACleanup; external winsocket name 'WSACleanup';
 
 {$R *.DFM}
 
 //
 // Function: checksum
 //
 // Description:
 // This function calculates the 16-bit one's complement sum
 // for the supplied buffer
 //
 function CheckSum(var Buffer; Size : integer) : Word;
 type
   TWordArray = array[0..1] of Word;
 var
   ChkSum : LongWord;
   i : Integer;
 begin
   ChkSum := 0;
   i := 0;
   while Size > 1 do
   begin
     ChkSum := ChkSum + TWordArray(Buffer)[i];
     inc(i);
     Size := Size - SizeOf(Word);
   end;
 
   if Size=1 then
     ChkSum := ChkSum + Byte(TWordArray(Buffer)[i]);
 
   ChkSum := (ChkSum shr 16) + (ChkSum and $FFFF);
   ChkSum := ChkSum + (Chksum shr 16);
 
   Result := Word(ChkSum);
 end;
 
 
 procedure BuildHeaders(FromIP : string; iFromPort : Word; ToIP : string;
 iToPort : Word; StrMessage : string; var Buf : TPacketBuffer;
 var remote : TSockAddr; var iTotalSize: Word);
 var
   dwFromIP : LongWord;
   dwToIP : LongWord;
 
   iIPVersion : Word;
   iIPSize : Word;
   ipHdr : T_IP_Header;
   udpHdr : T_UDP_Header;
 
   iUdpSize : Word;
   iUdpChecksumSize : Word;
   cksum : Word;
 
   Ptr : ^Byte;
 
   procedure IncPtr(Value : Integer);
   begin
     ptr := pointer(integer(ptr) + Value);
   end;
 
 begin
   // преобразуем ip адреса
 
   dwFromIP := inet_Addr(PChar(FromIP));
   dwToIP := inet_Addr(PChar(ToIP));
 
   // Инициализируем заголовок IP пакета
   //
   iTotalSize := sizeof(ipHdr) + sizeof(udpHdr) + length(strMessage);
 
   iIPVersion := 4;
   iIPSize := sizeof(ipHdr) div sizeof(LongWord);
   //
   // IP version goes in the high order 4 bits of ip_verlen. The
   // IP header length (in 32-bit words) goes in the lower 4 bits.
   //
   ipHdr.ip_verlen := (iIPVersion shl 4) or iIPSize;
   ipHdr.ip_tos := 0; // IP type of service
   ipHdr.ip_totallength := htons(iTotalSize); // Total packet len
   ipHdr.ip_id := 0; // Unique identifier: set to 0
   ipHdr.ip_offset := 0; // Fragment offset field
   ipHdr.ip_ttl := 128; // время жизни пакета
   ipHdr.ip_protocol := $11; // Protocol(UDP)
   ipHdr.ip_checksum := 0 ; // IP checksum
   ipHdr.ip_srcaddr := dwFromIP; // Source address
   ipHdr.ip_destaddr := dwToIP; // Destination address
   //
   // Инициализируем заголовок UDP пакета
   //
   iUdpSize := sizeof(udpHdr) + length(strMessage);
 
   udpHdr.src_portno := htons(iFromPort) ;
   udpHdr.dst_portno := htons(iToPort) ;
   udpHdr.udp_length := htons(iUdpSize) ;
   udpHdr.udp_checksum := 0 ;
   //
   // Build the UDP pseudo-header for calculating the UDP checksum.
   // The pseudo-header consists of the 32-bit source IP address,
   // the 32-bit destination IP address, a zero byte, the 8-bit
   // IP protocol field, the 16-bit UDP length, and the UDP
   // header itself along with its data (padded with a 0 if
   // the data is odd length).
   //
   iUdpChecksumSize := 0;
 
   ptr := @buf[0];
   FillChar(Buf, SizeOf(Buf), 0);
 
   Move(ipHdr.ip_srcaddr, ptr^, SizeOf(ipHdr.ip_srcaddr));
   IncPtr(SizeOf(ipHdr.ip_srcaddr));
 
   iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_srcaddr);
 
   Move(ipHdr.ip_destaddr, ptr^, SizeOf(ipHdr.ip_destaddr));
   IncPtr(SizeOf(ipHdr.ip_destaddr));
 
   iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_destaddr);
 
   IncPtr(1);
 
   Inc(iUdpChecksumSize);
 
   Move(ipHdr.ip_protocol, ptr^, sizeof(ipHdr.ip_protocol));
   IncPtr(sizeof(ipHdr.ip_protocol));
   iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_protocol);
 
   Move(udpHdr.udp_length, ptr^, sizeof(udpHdr.udp_length));
   IncPtr(sizeof(udpHdr.udp_length));
   iUdpChecksumSize := iUdpChecksumSize + sizeof(udpHdr.udp_length);
 
   move(udpHdr, ptr^, sizeof(udpHdr));
   IncPtr(sizeof(udpHdr));
   iUdpChecksumSize := iUdpCheckSumSize + sizeof(udpHdr);
 
   Move(StrMessage[1], ptr^, Length(strMessage));
   IncPtr(Length(StrMessage));
 
   iUdpChecksumSize := iUdpChecksumSize + length(strMessage);
 
   cksum := checksum(buf, iUdpChecksumSize);
   udpHdr.udp_checksum := cksum;
 
   //
   // Now assemble the IP and UDP headers along with the data
   // so we can send it
   //
   FillChar(Buf, SizeOf(Buf), 0);
   Ptr := @Buf[0];
 
   Move(ipHdr, ptr^, SizeOf(ipHdr)); IncPtr(SizeOf(ipHdr));
   Move(udpHdr, ptr^, SizeOf(udpHdr)); IncPtr(SizeOf(udpHdr));
   Move(StrMessage[1], ptr^, length(StrMessage));
 
   // Apparently, this SOCKADDR_IN structure makes no difference.
   // Whatever we put as the destination IP addr in the IP header
   // is what goes. Specifying a different destination in remote
   // will be ignored.
   //
   remote.sin_family := AF_INET;
   remote.sin_port := htons(iToPort);
   remote.sin_addr.s_addr := dwToIP;
 end;
 
 procedure TForm1.SendIt;
 var
   sh : TSocket;
   bOpt : Integer;
   ret : Integer;
   Buf : TPacketBuffer;
   Remote : TSockAddr;
   Local : TSockAddr;
   iTotalSize : Word;
   wsdata : TWSAdata;
 begin
   // Startup Winsock 2
   ret := WSAStartup($0002, wsdata);
   if ret<>0 then
   begin
     memo1.lines.add('WSA Startup failed.');
     exit;
   end;
   with memo1.lines do
   begin
     add('WSA Startup:');
     add('Desc.: '+wsData.szDescription);
     add('Status: '+wsData.szSystemStatus);
   end;
 
   try
     // Создаём сокет
     sh := Socket(AF_INET, SOCK_RAW, IPPROTO_UDP);
     if (sh = INVALID_SOCKET) then
     begin
       memo1.lines.add('Socket() failed: '+IntToStr(WSAGetLastError));
       exit;
     end;
     Memo1.lines.add('Socket Handle = '+IntToStr(sh));
 
     // Option: Header Include
     bOpt := 1;
     ret := SetSockOpt(sh, IPPROTO_IP, IP_HDRINCL, @bOpt, SizeOf(bOpt));
     if ret = SOCKET_ERROR then
     begin
       Memo1.lines.add('setsockopt(IP_HDRINCL) failed: '+IntToStr(WSAGetLastError));
       exit;
     end;
 
     // строим пакет
     BuildHeaders( SrcIP, SrcPort,
     DestIP, DestPort,
     'THIS IS A TEST PACKET',
     Buf, Remote, iTotalSize );
 
     // Отправляем пакет
     ret := SendTo(sh, buf, iTotalSize, 0, Remote, SizeOf(Remote));
     if ret = SOCKET_ERROR then
       Memo1.Lines.Add('sendto() failed: '+IntToStr(WSAGetLastError))
     else
       Memo1.Lines.Add('send '+IntToStr(ret)+' bytes.');
 
     // Закрываем сокет
     CloseSocket(sh);
   finally
     // Закрываем Winsock 2
     WSACleanup;
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   SendIt;
 end;
 
 end.
 




Передать строки, картинки (streams) между процессами


 {
   The WM_COPYDATA messages makes it possible to transfer information
   between processes. It does this by passing the data through the kernel.
   Space is allocated in the receiving process to hold the information that is copied,
   by the kernel, from the source process to the target process.
   The sender passes a pointer to a COPYDATASTRUCT, which is defined as a structure
   of the following:
 }
 
 type
   TCopyDataStruct = packed record
     dwData: DWORD;   // anwendungsspezifischer Wert 
     cbData: DWORD;   // Byte-Lдnge der zu ьbertragenden Daten 
     lpData: Pointer; // Adresse der Daten 
   end;
 
 
 { Sender Application }
 
 unit SenderApp;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, ExtCtrls;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     Edit1: TEdit;
     Button2: TButton;
     Image1: TImage;
     procedure Button1Click(Sender: TObject);
     procedure Button2Click(Sender: TObject);
   private
     procedure SendCopyData(hTargetWnd: HWND; ACopyDataStruct:TCopyDataStruct);
   public
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 // Sender: Send data 
 procedure TForm1.SendCopyData(hTargetWnd: HWND; ACopyDataStruct:TCopyDataStruct);
 begin
   if hTargetWnd <> 0 then
     SendMessage(hTargetWnd, WM_COPYDATA, Longint(Handle), Longint(@ACopyDataStruct))
   else
     ShowMessage('No Recipient found!');
 end;
 
 // Send Text from Edit1 to other app 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   MyCopyDataStruct: TCopyDataStruct;
   hTargetWnd: HWND;
 begin
   // Set up a COPYDATASTRUCT structure for use with WM_COPYDATA 
   // TCopyDataStruct mit den Sende-Daten Infos ausfьllen 
   with MyCopyDataStruct do
   begin
     dwData := 0; // may use a value do identify content of message 
     cbData := StrLen(PChar(Edit1.Text)) + 1;  //Need to transfer terminating #0 as well 
     lpData := PChar(Edit1.Text)
   end;
   // Find the destination window for the WM_COPYDATA message 
   // Empfдnger Fenster anhand des Titelzeilentextes suchen 
   hTargetWnd := FindWindow(nil,PChar('Message Receiver'));
   // send the structure to the receiver 
   // Die Struktur an den Empfдnger schicken 
   SendCopyData(hTargetWnd, MyCopyDataStruct);
 end;
 
 // Send Image1 to other app 
 procedure TForm1.Button2Click(Sender: TObject);
 var
   ms: TMemoryStream;
   MyCopyDataStruct: TCopyDataStruct;
   hTargetWnd: HWND;
 begin
   ms := TMemoryStream.Create;
   try
     image1.Picture.Bitmap.SaveToStream(ms);
     with MyCopyDataStruct do
     begin
       dwData := 1;
       cbData := ms.Size;
       lpData := ms.Memory;
     end;
     // Search window by the window title 
     // Empfдnger Fenster anhand des Titelzeilentextes suchen 
     hTargetWnd := FindWindow(nil,PChar('Message Receiver'));
     // Send the Data 
     // Daten Senden 
     SendCopyData(hTargetWnd,MyCopyDataStruct);
   finally
     ms.Free;
   end;
 end;
 
 end.
 
 {*********************************************************************}
 
 { Receiver Application }
 
 unit ReceiverApp;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   ExtCtrls, StdCtrls;
 
 type
   TForm1 = class(TForm)
     Image1: TImage;
     Label1: TLabel;
   private
     procedure WMCopyData(var Msg: TWMCopyData); message WM_COPYDATA;
     { Private-Deklarationen }
   public
     { Public-Deklarationen }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.WMCopyData(var Msg: TWMCopyData);
 var
   sText: array[0..99] of Char;
   ms: TMemoryStream;
 begin
   case Msg.CopyDataStruct.dwData of
     0: { Receive Text, Text empfangen}
       begin
         StrLCopy(sText, Msg.CopyDataStruct.lpData, Msg.CopyDataStruct.cbData);
         label1.Caption := sText;
       end;
     1: { Receive Image, Bild empfangen}
       begin
         ms := TMemoryStream.Create;
         try
           with Msg.CopyDataStruct^ do
            ms.Write(lpdata^, cbdata);
            ms.Position := 0;
           image1.Picture.Bitmap.LoadFromStream(ms);
         finally
           ms.Free;
         end;
       end;
   end;
 end;
 end.
 




Как передать строку другому приложению

получатель:


 procedure ReceiveMessage (var Msg: TMessage);
 message WM_COPYDATA;
 ...
 procedure TFormReceive.ReceiveMessage;
 var
   pcd: PCopyDataStruct;
 begin
   pcd := PCopyDataStruct(Msg.LParam);
   Caption := PChar(pcd.lpData);
 end;
 

отправитель:


 procedure TFormXXX.Button1Click(Sender: TObject);
 var
   cd: TCopyDataStruct;
 begin
   cd.cbData := Length(Edit1.Text) + 1;
   cd.lpData := PChar(Edit1.Text);
   SendMessage(FindWindow('TFormReceive', nil), WM_COPYDATA, 0, LParam(@cd));
 end;
 




Как отправить на принтер чистый поток данных

Под Win16 Вы можете использовать функцию SpoolFile, или Passthrough escape, если принтер поддерживает последнее. Под Win32 Вы можете использовать WritePrinter.

Ниже пример открытия принтера и записи чистого потока данных в принтер. Учтите, что Вы должны передать корректное имя принтера, такое, как "HP LaserJet 5MP", чтобы функция сработала успешно.

Конечно, Вы можете включать в поток данных любые необходимые управляющие коды, которые могут потребоваться.


 uses WinSpool;
 
 procedure WriteRawStringToPrinter(PrinterName:string; S:string);
 var
   Handle: THandle;
   N: DWORD;
   DocInfo1: TDocInfo1;
 begin
   if not OpenPrinter(PChar(PrinterName), Handle, nil) then
   begin
     ShowMessage('Error ' + IntToStr(GetLastError));
     Exit;
   end;
   with DocInfo1 do
   begin
     pDocName := PChar('test doc');
     pOutputFile := nil;
     pDataType := 'RAW';
   end;
   StartDocPrinter(Handle, 1, @DocInfo1);
   StartPagePrinter(Handle);
   WritePrinter(Handle, PChar(S), Length(S), N);
   EndPagePrinter(Handle);
   EndDocPrinter(Handle);
   ClosePrinter(Handle);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   WriteRawStringToPrinter('HP', 'Test This');
 end;
 

Посмотри и доделай как тебе надо:


 unit TextPrinter;
 
 interface
 
 uses
   Windows, Controls, Forms, Dialogs;
 
 type
   TTextPrinter = class(TObject)
     FNumberOfBytesWritten: Integer;
     FHandle: THandle;
     FPrinterOpen: Boolean;
     FErrorString: PChar;
     procedure SetErrorString;
   public
     constructor Create;
     procedure write(const Str: string);
     procedure WriteLn(const Str: string);
     destructor Destroy; override;
   published
     property NumberOfBytesWritten: Integer read FNumberOfBytesWritten;
 end;
 
 implementation
 
 {TTextPrinter}
 
 constructor TTextPrinter.Create;
 begin
   FHandle := CreateFile('LPT1', GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ
   or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
   if FHandle = INVALID_HANDLE_VALUE then
   begin
     SetErrorString;
     raise Exception.Create(FErrorString);
   end
   else
     FPrinterOpen := True;
 end;
 
 procedure TTextPrinter.SetErrorString;
 begin
   if FErrorString <> nil then
   LocalFree(Integer(FErrorString));
   FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,
   nil, GetLastError(), LANG_USER_DEFAULT, @FErrorString, 0, nil);
 end;
 
 procedure TTextPrinter.write(const Str: string);
 var
   OEMStr: PChar;
   NumberOfBytesToWrite: Integer;
 begin
   if not FPrinterOpen then
     Exit;
   NumberOfBytesToWrite := Length(Str);
   OEMStr := PChar(LocalAlloc(LMEM_FIXED, NumberOfBytesToWrite + 1));
   try
     CharToOem(PChar(Str), OEMStr);
     if not WriteFile(FHandle, OEMStr^, NumberOfBytesToWrite, FNumberOfBytesWritten, nil) then
     begin
       SetErrorString;
       raise Exception.Create(FErrorString);
     end;
   finally
     LocalFree(Integer(OEMStr));
   end;
 end;
 
 procedure TTextPrinter.WriteLn(const Str: string);
 begin
   Self.write(Str);
   Self.write(#10);
 end;
 
 destructor TTextPrinter.Destroy;
 begin
   CloseHandle(FHandle);
   if FErrorString <> nil then
     LocalFree(Integer(FErrorString));
 end;
 
 end.
 

P.S. В принципе, вместо LPT1 может стоять что угодно, даже сетевой сервер печати (\\server\prn) - все равно печатает. Можно и параметр в конструктор вставить и т.д.




Как передать UserName и Password в удаленный модуль данных

В Удаленный Модуль Данных бросьте компонент TDatabase, затем добавьте процедуру автоматизации (пункт главного меню Edit | Add To Interface) для Login.

Убедитесь, что свойство HandleShared компонента TDatabase установлено в True.


 procedure Login(UserName, Password: WideString);
 begin
   { DB = TDatabase }
   { Something unique between clients }
   DB.DatabaseName := UserName + 'DB';
   DB.Params.Values['USER NAME'] := UserName;
   DB.Params.Values['PASSWORD'] := Password;
   DB.Open;
 end;
 

После того, как Вы создали этот метод автоматизации, Вы можете вызывать его с помощью:


 RemoteServer1.AppServer.Login('USERNAME','PASSWORD');
 




Как отправить вебформу на сервер при помощи TClientSocket (напрямую и через прокси)

Посетитель у провайдера.
- Ой, что это у вас так крякнуло.
- Сервер наверное...


 {
 Присоедините следующие события к Вашему ClientSocket:
 procedure T...Form.ClientSocket1Write;
 procedure T...Form.ClientSocket1Read;
 procedure T...Form.ClientSocket1Disconnect;
 procedure T...Form.ClientSocket1Error;
 
 Так же пример показывает, как направлять передачу через прокси-сервер.
 
 Для отправки на вебсервер используется следующий формат:
 Напрямую:
   'POST ' + PostAddr + 'HTTP/1.0' + HTTP_Data + Content
 Через проксю:
   'POST http://' Webserver + PostAddr + 'HTTP/1.0' + HTTP_Data + Content
 }
 
 
 const
   WebServer = 'www.somehost.com';
   WebPort = 80;
   PostAddr = '/cgi-bin/form';
 
   { Следующие переменные используются только для вебсервера: }
   ProxyServer ='proxy.somewhere.com';
   ProxyPort = 3128;
 
   // В заголовке post необходимы некоторые данные
   HTTP_Data =
   'Content-Type: application/x-www-form-urlencoded'#10+
   'User-Agent: Delphi/5.0 ()'#10+ { Отрекламируем Delphi 5! }
   'Host: somewhere.com'#10+
   'Connection: Keep-Alive'#10;
 
 type
   T...Form = class(TForm)
     ...
   private
     { Private declarations }
     HTTP_POST : string;
     FContent : string;
     // Эта переменная будет содержать ответ сервера
     FResult : string;
   public
     { Public declarations }
 end;
 
 
 { Эти функции сделают некоторое url-кодирование }
 { Например. 'John Smith' => 'John+Smith' }
 function HTTPTran(St: string): string;
 var
   i: Integer;
 begin
   Result:='';
   for i:=1 to length(St) do
     if St[i] in ['a'..'z','A'..'Z','0','1'..'9'] then
       Result:=Result+St[i]
     else
       if St[i]=' ' then
         Result:=Result+'+'
       else
         Result:=Result+'%'+IntToHex(Byte(St[i]),2);
 end;
 
 procedure T...Form.ClientSocket1Write(Sender: TObject;
 Socket: TCustomWinSocket);
 begin
   // Постим данные
   Socket.SendText(HTTP_POST+FContent);
 end;
 
 procedure T...Form.ClientSocket1Read(Sender: TObject;
 Socket: TCustomWinSocket);
 begin
   // Получаем результат
   FResult:=FResult+Socket.ReceiveText;
 end;
 
 procedure T...Form.ClientSocket1Disconnect(Sender: TObject;
 Socket: TCustomWinSocket);
 begin
   // ЗДЕСЬ МОЖНО ОБРАБОТАТЬ FResult //
 end;
 
 procedure T...Form.ClientSocket1Error(Sender: TObject;
 Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
 var ErrorCode: Integer);
 begin
   ErrorCode := 0; // Игнорируем ошибки
 end;
 
 
 { А эта подпрограмма, которую можно
 использовать для постинга данных формы. }
 
 procedure T...Form.PostTheForm;
 begin
   // Очищаем результаты
   FResult:='';
 
   // Вы можете ввести поля формы, которые необходимы
   // Вот некоторые примеры:
   FContent:=
   'Name='+ HTTPTran('John Smith') +'&'+
   'Address='+ HTTPTran('1 Waystreet') +'&'+
   'Email='+ HTTPTran('jsmith@somewhere.com') +'&'+
   'B1=Submit' +  #10;
 
   // Вычисляем длину содержимого
   FContent:=
   'Content-Length: '+IntToStr(Length(FContent))+#10+#10+FContent;
 
   {-- Начало прокси ---}
   { если Вы используете прокси, то раскоментируйте этот код }
   ClientSocket1.Host := ProxyServer;
   ClientSocket1.Port := ProxyPort;
   HTTP_POST := 'POST http:  //'+WebServer+PostAddr+' HTTP/1.0'#10;
   {--- Конец прокси ---}
 
   {--- Начало соединения напрямую --- }
   { удалите этот код, еслы Вы будете использовать прокси }
   ClientSocket1.Host := WebServer;
   ClientSocket1.Port := WebPort;
   HTTP_POST := 'POST '+PostAddr+' HTTP/1.0'#10;
   {--- Конец соединения напрямую ---}
 
   // Соединяем заголовок
   HTTP_Post := HTTP_Post + HTTP_Data;
 
   // Пытаемся открыть соединение
   ClientSocket1.Open;
 end;
 




Как разделить обработку OnClick и OnDblClick

Ведь OnClick будет вызываться всегда, и перед DblClick.

Именно так и происходит в Windows - посылаются оба сообщения. Для того чтобы обработать только какое-то одно событие необходимо чуть " задержать" выполнение OnClick. Сделать это можно следующим способом:


 procedure TForm1.ListBox1Click(Sender: TObject);
 var
   Msg: TMsg;
   TargetTime: Longint;
 begin
   { get the maximum time to wait for a double-click message }
   TargetTime := GetTickCount + GetDoubleClickTime;
   { cycle until DblClick received or wait time run out }
   while GetTickCount <  TargetTime do
     if PeekMessage(Msg, ListBox1.Handle, WM_LBUTTONDBLCLK,
     WM_LBUTTONDBLCLK, WM_NOREMOVE)
     then Exit; { Double click }
   MessageDlg('Single clicked', mtInformation, [mbOK], 0);
 end;
 




Регистрация основанная на серийных ключах

Автор: Владимир Каталов

Эту статейку написал скорее всего Владимир Каталов на тему защиты shareware-программ, но я думаю что она будет полезна не только программистам, но и крэкерам тоже.

При хорошем знании ассемблера очень просто обойти защиту типа имя пользователя-регкод: когда пользователь вводит свое имя и регистрационный код, программа генерирует "правильный" код и сравнивает его с тем, который он ввел, поэтому "перехватить" этот код (просто считать его из памяти) не составлет особого труда. В большинстве случаев достаточно просто поставить breakpoint на функцию lstrcmp -- и все дела... Упаковка программы, анти-дебаггерные и анти-дизассемблерные "примочки" помогают слабо.

А вот метод фиксированного ключа может быть реализован достаточно неплохо. Хранить "правильные" ключи в программе совсем не обязательно - можно подчинить их некоторым правилам; что-то подобное делает Microsoft со своими CD-keys, но у них все слишком просто. Алгоритм проверки может быть длинным и запутанным, так что его дизассемблирование (и "разборка", что же он делает) причинит немало головной боли. Именно первый метод я и применил для защиты своей программы (Advanced Disk Catalog - старые версии), но и он был "сломан" (хотя, как мне написал ломавший его хакер, подборка всего двух правильных ключей отняла у него много времени). Тогда мне в голову пришла идея: а что, если ключи хранить внутри программы, но зашифрованными? Я "сгенерил" некоторое количество ключей (абсолютно случайным образом), зашифровал их (по отдельности) 128-битным ключом по алгоритму RSA и прошил в программу в виде ресурса. Когда пользователь вводит ключ, он шифруется по тому же алгоритму и сравнивается с правильными. Так как система с открытым ключом не позволяет произвести обратное преобразование, базируясь только на открытом ключе (а закрытого нет даже у меня - расшифровывать-то не надо), то подобрать ключи невозможно даже теоретически.

Есть, впрочем, еще одна проблема: хакер (или "крэкер", если угодно) может заменить 'je' на 'jne' (или что-то в этом роде) там, где происходит последняя проверка, и функция "IsValidKey(...)" будет всегда возвращать TRUE. Останется лишь написать маленький patch... Чтобы защититься и от этого, я вычисляю CRC своего exe-файла и сравниваю его с правильный, прошитым тоже внутри программы (естественно, при вычислении эта часть файла -- где лежит правильный CRC -- исключается; а "прошивается" он после компиляции). Кстати, это еще и защита от вирусов. Вообще-то, проверку CRC тоже можно локализовать и "запатчить", но это уже немного сложнее, особенно если программа вызывает функции чтения/записи и для других целей. Кроме того, не стоит в случае несовпадения CRC сразу об этом сообщать, иначе можно будет поставить hardware breakpoint и найти место, где он вычисляется. И последнее. Если хочется защитить программы совсем уж "круто", томожно несколько функций в своей программе (те, которые должны вызываться только в зарегистрированной версии), зашифровать по тому же алгоритму с открытым ключом. При этом, естественно, часть серийного номера (отсылаемого зарегистрировавшимся) надо сделать "статическим", т.е. неизменным для всех пользователей. На основе этой части после регистрации генерируется полный закрытый ключ, который далее используется для расшифровки указанных функций. Таким образом, даже если будет написан patch, позволяющий "зарегистрироваться" с любым (произвольным) кодом, расшифровка пройдет неправильно, и вместо нормального кода будет выполняться "мусор".

Этот способ я применил в другой своей программе (Advanced ZIP Password Recovery), и ее пока не вскрыли. Всего наилучшего !

Комментарий от Bad_guy: действительно, если некоторые нужные функции зашифрованы, расшифровать их практически невозможно, и я бы сказал, что для защиты программы этого метода с лихвой достаточно, но никогда не надо забывать, что есть такой способ взлома как кража правильного кода (хотя такой метод противоречит крэкерской этике, да и не крэкерство это вовсе). На мой же взгляд программа - это сейф, содержимое которого вам известно, и прежде чем начинать взламывать этот сейф надо подумать: так ли вам нужно его содержимое ? Автор вот говорит - никто не взломает Advanced ZIP Password Recovery, ну и пускай спит спокойно, а я пока поищу бесплатный аналог (если припрёт).




SetFocus в TStringGrid


 Grid.Row := YourRowNumber;
 Grid.TopRow := YourFirstVisibleRow;
 Grid.LeftCol := YourFirstVisibleColumn;
 




SetFocus в Edit на OnExit

Встречаются как то НАШ Российский хакер и ихний БИЛ ГЕЙТС!
ГЕЙТС: Слушай у тебя случайно Wind(Ы)2000 нет, а то Рождество на Носу, а подарить друзьям нечего? Все деньги жена забирает!
ХАКЕР: Есть! Что за вопросы! А ТЕБЕ КАКУЮ, Русскую или Английскую?

Я пробую выполнить editbox.SetFocus и/или editbox.Clear, но но это не дает никакого эффекта (по крайней мере видимого). Что я делаю неправильно?

Вы посылаете команду на изменение фокуса внутри обработчика, который сам устанавливает фокус, этим вы получаете банальную рекурсию.

Я избегаю этого путем отправления собственного сообщения в обработчике OnExit, после чего в обработчике моего сообщения выставляю логический флажок, предохраняющий код от рекурсии, поскольку данный флажок контролируется в обработчике OnExit.

Следующие строки содержат необходимый код:


 interface
 ........
 const
   WM_MyExitRtn = WM_USER + 1001;
   ........
   type
   TForm1 = class(TForm)
     .........
     private
     bExitInProgress: Boolean; {предохраняемся от рекурсий сообщений}
   public
     procedure WMMyExitRtn(var msg: TMessage); message WM_MyExitRtn;
   end;
   .........
   implementation
 .........
 
 procedure TForm1.DBEdit1Exit(Sender: TObject);
 begin
   if not bExitInProgress then
     PostMessage(Handle, WM_MyExitRtn, 0, LongInt(Sender));
 end;
 .........
 
 procedure TForm1.WMMyExitRtn(var msg: TMessage);
 begin
   bExitInProgress := True; { предохраняемся от рекурсивного вызова }
   {здесь содержится необходимый код }
   bExitInProgress := False; { сбрасываем флаг }
 end;
 




Правила для SetRange

Автор: Josh

Я, похоже, обнаружил неплохое решение ранжирования данных - вам необходимо только установить различные начальный и конечный диапазоны последнего поля, определенного вашим индексом, после чего введенное в любое поле индекса значение будет проигнорировано. Также вы не сможете покинуть ранжируемое поле, если редактируемая запись пуста.

Попытаюсь изложить все попроще... Скажем, у меня есть индекс Field1; Field2; Field3, затем;


 SetRangeStart;
 Table1Field1.Value := x1;
 Table1Field2.Value := y1;
 Table1Field3.Value := z1;
 SetRangeEnd;
 Table1Field1.Value := x2;
 Table1Field2.Value := y2;
 Table1Field3.Value := z2;
 ApplyRange;
 

Правила...

x1 должен равняться x2, если y или z определен
y1 должен равняться y2, если z определен
x должен быть определен, если y или z определены
y должен быть определен, если x определен
если x1 = x2 и никаких других критериев не определено, тогда y1 и y2 должны быть соответственно min/max значениями y
если x1 = x2 и y1 = y2 и никаких других критериев не определено, тогда z1 и z2 должны быть соответственно min/max значениями z

Я не знаю, поняли вы это или нет, но надеюсь это поможет...




Пример SetText, GetText строкового поля

Автор: Mike Orriss

Ниже приведен простой пример поля ID, содержащего A,B,C, для вывода (и обновления) *всех* элементов управления как 1,2,3:


 procedure TForm1.Table1IDGetText(Sender: TField;
   var Text: OpenString; DisplayText: Boolean);
 var
   s: string;
 begin
   s := (Sender as TStringField).Value;
   case s[1] of
     'A': Text := '1';
     'B': Text := '2';
     'C': Text := '3';
   else
     Text := '9'
   end;
 end;
 
 procedure TForm1.Table1IDSetText(Sender: TField; const Text: string);
 var
   s: string;
 begin
   case Text[1] of
     '1': s := 'A';
     '2': s := 'B';
     '3': s := 'C';
   else
     s := 'Z'
   end;
   (Sender as TStringField).Value := s;
 end;
 




Установка привилегий

Hе забуду мать родную - ZX Spectrum навсегда!


 {
   For some functions you need to get the right privileges
   on a Windows NT machine.
   (e.g: To shut down or restart windows with ExitWindowsEx or
   to change the system time)
   The following code provides a procedure to adjust the privileges.
   The AdjustTokenPrivileges() function enables or disables privileges
   in the specified access token.
 }
 
 // NT Defined Privileges from winnt.h 
 
 const
   SE_CREATE_TOKEN_NAME = 'SeCreateTokenPrivilege';
   SE_ASSIGNPRIMARYTOKEN_NAME = 'SeAssignPrimaryTokenPrivilege';
   SE_LOCK_MEMORY_NAME = 'SeLockMemoryPrivilege';
   SE_INCREASE_QUOTA_NAME = 'SeIncreaseQuotaPrivilege';
   SE_UNSOLICITED_INPUT_NAME = 'SeUnsolicitedInputPrivilege';
   SE_MACHINE_ACCOUNT_NAME = 'SeMachineAccountPrivilege';
   SE_TCB_NAME = 'SeTcbPrivilege';
   SE_SECURITY_NAME = 'SeSecurityPrivilege';
   SE_TAKE_OWNERSHIP_NAME = 'SeTakeOwnershipPrivilege';
   SE_LOAD_DRIVER_NAME = 'SeLoadDriverPrivilege';
   SE_SYSTEM_PROFILE_NAME = 'SeSystemProfilePrivilege';
   SE_SYSTEMTIME_NAME = 'SeSystemtimePrivilege';
   SE_PROF_SINGLE_PROCESS_NAME = 'SeProfileSingleProcessPrivilege';
   SE_INC_BASE_PRIORITY_NAME = 'SeIncreaseBasePriorityPrivilege';
   SE_CREATE_PAGEFILE_NAME = 'SeCreatePagefilePrivilege';
   SE_CREATE_PERMANENT_NAME = 'SeCreatePermanentPrivilege';
   SE_BACKUP_NAME = 'SeBackupPrivilege';
   SE_RESTORE_NAME = 'SeRestorePrivilege';
   SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
   SE_DEBUG_NAME = 'SeDebugPrivilege';
   SE_AUDIT_NAME = 'SeAuditPrivilege';
   SE_SYSTEM_ENVIRONMENT_NAME = 'SeSystemEnvironmentPrivilege';
   SE_CHANGE_NOTIFY_NAME = 'SeChangeNotifyPrivilege';
   SE_REMOTE_SHUTDOWN_NAME = 'SeRemoteShutdownPrivilege';
   SE_UNDOCK_NAME = 'SeUndockPrivilege';
   SE_SYNC_AGENT_NAME = 'SeSyncAgentPrivilege';
   SE_ENABLE_DELEGATION_NAME = 'SeEnableDelegationPrivilege';
   SE_MANAGE_VOLUME_NAME = 'SeManageVolumePrivilege';
 
 // Enables or disables privileges debending on the bEnabled 
 function NTSetPrivilege(sPrivilege: string; bEnabled: Boolean): Boolean;
 var
   hToken: THandle;
   TokenPriv: TOKEN_PRIVILEGES;
   PrevTokenPriv: TOKEN_PRIVILEGES;
   ReturnLength: Cardinal;
 begin
   Result := True;
   // Only for Windows NT/2000/XP and later. 
   if not (Win32Platform = VER_PLATFORM_WIN32_NT) then Exit;
   Result := False;
 
   // obtain the processes token 
   if OpenProcessToken(GetCurrentProcess(),
     TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
   begin
     try
       // Get the locally unique identifier (LUID) . 
       if LookupPrivilegeValue(nil, PChar(sPrivilege),
         TokenPriv.Privileges[0].Luid) then
       begin
         TokenPriv.PrivilegeCount := 1; // one privilege to set 
 
         case bEnabled of
           True: TokenPriv.Privileges[0].Attributes  := SE_PRIVILEGE_ENABLED;
           False: TokenPriv.Privileges[0].Attributes := 0;
         end;
 
         ReturnLength := 0; // replaces a var parameter 
         PrevTokenPriv := TokenPriv;
 
         // enable or disable the privilege 
 
         AdjustTokenPrivileges(hToken, False, TokenPriv, SizeOf(PrevTokenPriv),
           PrevTokenPriv, ReturnLength);
       end;
     finally
       CloseHandle(hToken);
     end;
   end;
   // test the return value of AdjustTokenPrivileges. 
   Result := GetLastError = ERROR_SUCCESS;
   if not Result then
     raise Exception.Create(SysErrorMessage(GetLastError));
 end;
 




SetVolume почему-то не дает никакого эффекта

Новая компьютерная игра МУ-МУ.
Герасим использует Му-му по умолчанию.

В модуле MMSystem есть функции

  • waveOutSetVolume(WAVE_MAPPER, AVolume)
  • midiOutSetVolume(MIDI_MAPPER, AVolume)

которые регулируют громкость в зависимости от формата музыки.

  • AVolume: Longint - старший разряд - правый канал, младший - левый



Установка режима бинарного файла

Автор: Steve

Попробуйте вызвать приведенную ниже процедуру немедленно после перезаписи выходного файла и перед началом записи в него:


 procedure SetBinaryMode(var F: file); assembler;
 asm
   mov ax,$4400
   les di,F
   mov bx,word ptr es:[di]
   int $21
   or dl,$20
   xor dh,dh
   mov ax,$4401
   int $21
 end;
 




Установка времени компиляции программы в диалоговом окне О программе

Я подразумаваю, что проблема состоит в получении времени компиляции?


 Var
   F: Integer;
   S: String;
 Begin
   F:=FileOpen(ExpandFileName(Application.ExeName), 0);
   S:=TimeToStr(FileDateToDateTime(FileGetDate(F)));
   FileClose(F);
 End;
 

Взгляните на описание функции DateTime... в файле помощи. Вероятно, существует лучший способ получения времени без использования функции FileOpen.

Также можно использовать время файла (File Time) в качестве номера версии, так, время 6:02 обозначало бы версию 6.02, и устанавливать его чем-то типа Touch.




Установить флаг DTR и RTS в активное состояние для определённого COM-порта

Автор: Slava V

После открытия com-порта через CreateFile() необходимо с помощью GetCommState() и SetCommState() установить параметры порта (в частности убрать автоуправление RTS и DTR). Затем для установки соответствующих сигналов используется функция EscapeCommFunction().


 Procedure ControlRTS;
 Var
   S: String;
   lDCB: TDCB;
   fHandle: THandle;
 Begin
   S:='COM1';
   // open port
   fHandle:=CreateFile( Pchar(S), GENERIC_READ Or GENERIC_WRITE, 0,
   Nil, OPEN_EXISTING, 0, 0);
   If fHandle=INVALID_HANDLE_VALUE Then
   Begin
     // can't open....
     Exit;
   End;
   // read settings
   If Not GetCommState( fHandle, lDCB) Then
   Begin
     // can't read
     Exit;
   End;
   // Fill dcb
   lDCB.BaudRate:=CBR_2400;
   lDCB.ByteSize:=8;
   lDCB.Parity:=NOPARITY;
   lDCB.StopBits:=ONESTOPBIT;
 
   // !!! we will manage RTS ourself !!!
   ldcb.Flags:=(ldcb.Flags And $FFFFC0FF) Or $00000100;
   // set comm state
   SetCommState( fHandle, ldcb);
 
   // Here we can manage
   // Reset RTS
   EscapeCommFunction( fHandle, CLRRTS);
   // Set RTS
   EscapeCommFunction( fHandle, SETRTS);
 
   // Close port
   CloseHandle(fHandle);
   fHandle:=0;
 End;
 

P.S. Надо заметить, что все выходы com-порта являются инверсными. А это значит, что активным сосотоянием порта является 0, а неактивным 1.




Как программно установить конфигурацию COM-порта


 procedure TForm1.Button1Click(Sender: TObject);
 var
   CommPort: string;
   hCommFile: THandle;
   Buffer: PCommConfig;
   size: DWORD;
 begin
   CommPort := 'COM1';
   {Открываем Com-порт}
   hCommFile := CreateFile(PChar(CommPort),
   GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
 
   if hCommFile = INVALID_HANDLE_VALUE then
   begin
     ShowMessage('Unable to open ' + CommPort);
     exit;
   end;
 
   {Выделяем временный буфер}
   GetMem(Buffer, sizeof(TCommConfig));
 
   {Получаем размер структуры CommConfig}
   size := 0;
   GetCommConfig(hCommFile, Buffer^, size);
 
   {Освобождаем временный буфер}
   FreeMem(Buffer, sizeof(TCommConfig));
 
   {Выделяем память для структуры CommConfig}
   GetMem(Buffer, size);
   GetCommConfig(hCommFile, Buffer^, size);
 
   {Изменяем скорость передачи}
   Buffer^.dcb.BaudRate := 1200;
 
   {Устанавливаем новую конфигурацию для COM-порта}
   SetCommConfig(hCommFile, Buffer^, size);
 
   {Освобождаем буфер}
   FreeMem(Buffer, size);
 
   {Закрываем COM-порт}
   CloseHandle(hCommFile);
 end;
 




Как програмным путем задавать координаты ярлыкам на рабочем столе

Автор: Сергей

Рабочий стол перекрыт сверху компонентом ListView. Вам просто необходимо взять хэндл этого органа управления. Пример:


 function GetDesktopListViewHandle: THandle;
 var
   S: String;
 begin
   Result := FindWindow('ProgMan', nil);
   Result := GetWindow(Result, GW_CHILD);
   Result := GetWindow(Result, GW_CHILD);
   SetLength(S, 40);
   GetClassName(Result, PChar(S), 39);
   if PChar(S) <> 'SysListView32' then
     Result := 0;
 end;
 

После того, как Вы взяли тот хэндл, Вы можете использовать API этого ListView, определенный в модуле CommCtrl, для того, чтобы манипулировать рабочим столом. Смотрите тему "LVM_xxxx messages" в оперативной справке по Win32.

К примеру, следующая строка кода:


 {Не забудьте в uses добавить CommCtrl}
 ListView_SetItemPosition(GetDesktopListViewHandle,i,x,y);
 

ярлыку с индексом i, задаст координаты (x,y). К примеру Мой компьютер имеет индекс 0, т.е i:=0;

С наилучшими пожеланиями, Сергей

Nomadic дополняет:

К примеру, следующая строка кода:


 SendMessage( GetDesktopListViewHandle, LVM_ALIGN, LVA_ALIGNLEFT, 0 );
 

разместит иконки рабочего стола по левой стороне рабочего стола Windows.




Как установить переменные окружения

- Чем Windows похожи на презерватив?
- Никому не нравится, но все используют.

Следующая простая подпрограмма создаёт новые значения в переменных окружения. Если переменной окружения не существует, то она создаётся. Если переменной окружения установить значение пустой строки, то переменная удаляется. Функция возвращает 0, если значение переменной установлено или переменная создана успешно, либо возвратит значение ошибки Windows вслучае неудачи. Обратите внимание, что размер пространства доступного для переменных окружения ограничен.


 function SetEnvVarValue(const VarName, VarValue: string): Integer;
 begin
   // Просто вызываем API функцию
   if Windows.SetEnvironmentVariable(PChar(VarName), PChar(VarValue)) then
     Result := 0
   else
     Result := GetLastError;
 end;
 

ЗАМЕЧАНИЕ:

данный способ позволяет делать изменения в переменных окружения только для текущего процесса либо для дочерних процессов, порождённых текущим.

Для того, чтобы передать какую-либо переменную окружения в дочерний процесс просто:

  • Создайте новую переменную окружения при помощи SetDOSEnvVar.
  • Запустите новую программу.

А вот как выглядит пример передачи текущих переменных окружения + переменной FOO=Bar в дочерний процесс:


 var
   ErrCode: Integer;
 begin
   ErrCode := SetEnvVarValue('FOO', 'Bar');
   if ErrCode = 0 then
     WinExec('MyChildProg.exe', SW_SHOWNORMAL);
   else
     ShowMessage(SysErrorMessage(ErrCode));
 end;
 

Так же можно воспользоваться примером, содержащем различные примеры работы с переменными окружения, который можно скачать здесь




Устанавливаем дату создания файла


 Function SetFileDate(
   Const FileName : String;
   Const FileDate : TDateTime): Boolean;
 var
  FileHandle        : THandle;
  FileSetDateResult : Integer;
 begin
  try
   try
    FileHandle := FileOpen
       (FileName,
        fmOpenWrite OR fmShareDenyNone);
    if FileHandle > 0 Then  begin
     FileSetDateResult :=
       FileSetDate(
         FileHandle,
         DateTimeToFileDate(FileDate));
       result := (FileSetDateResult = 0);
     end;
   except
    Result := False;
   end;
  finally
   FileClose (FileHandle);
  end;
 end;
 
 {Использование:}
 SetFileDate('c:\mydir\myfile.ext', Now)
 




Установка времени и даты файла

...вы были на правильном пути, когда заговорили о функции SetFTime. Ниже несколько строчек кода, которые изменяют значения даты & времени файла:


 var
   f: file;
 begin
   Assign(f, DirInfo.Name);
   Reset(f);
   SetFTime(f, Time);
   Close(f);
 end;
 




Установка ловушек в Windows

Если вы хотите чаще встречаться с понравившейся девушкой установите ей Windows'95

Сегодня мы поговорим об установке hook'ов (ловушек) в Windows. Hook - это механизм перехвата сообщений, путем установки специальной функции на верх стека hook-функций системы. Без установки таких ловушек практически невозможно обойтись при написании различных средств удаленного администрирования, шпионов и других программ в той или иной степени осуществляющих контроль за пользователем, использующем ОС Windows. Hook'и бывают глобальные (на всю систему) и локальные (на какой-либо поток).

Установить в систему hook можно при помощи функции SetWindowsHookEx(), со следующим заголовком:

 HHOOK SetWindowsHookEx(int idHook, HOOKPROC lpfn, HINSTANCE hMod, DWORD dwThreadId);
 

Если ты плохо воспринимаешь Си-шный код, на Delphi заголовок выглядит так:

 	SetWindowsHookEx(idHook: Integer; lpfn: TFNHookProc;
     			     hmod: HINST; dwThreadId: DWORD): HHOOK;
 

Функция SetWindowsHookEx() в случае установки hook'a возвращает его дескриптор, в случае ошибки возвращает 0.

Разберем подробней все входящие параметры этой функции:

1. idHook - константа, определяет типа устанавливаемого hook'а. Может принимать одно из ниже перечисленных значений:

WH_CALLWNDPROC - Следит за сообщениями до отправки в оконную функцию и вызывается, когда процедуре окна посылается сообщение. Ловушка срабатывает при каждом вызове функции SendMessage.

WH_CALLWNDPROCRET - Контролирует сообщения после их отправки в оконную функцию.

WH_CBT - Вызывается перед обработкой большинства сообщений окон, мыши и клавиатуры (созданием окон, активация окон, уничтожением окон, сменой размера окон, перед установкой фокуса и.т.п.)

WH_DEBUG - Вызывается перед любой другой ловушкой. Полезно для отладки hook'ов.

WH_GETMESSAGE - Вызывается, когда из очереди приложения считывается сообщение.

WH_HARDWARE - Вызывается, когда из очереди приложения считывается сообщение установленного на компьютере оборудования.

WH_JOURNALPLAYBACK - Вызывается, когда из очереди системы считывается сообщение. Применяется для добавления в очередь системных событий.

WH_JOURNALRECORD - Вызывается, когда из очереди системы запрашивается какое-нибудь событие. Применяется для регистрации системных событий.

WH_KEYBOARD - Вызывается, когда из очереди приложения считывается сообщения WM_Keydown или WM_Keyup. Одна из самых распространенных ловушек -).

WH_MOUSE - Вызывается, когда из очереди приложения считывается сообщение мыши.

WH_MSGFILTER - Вызывается, когда сообщение должно быть обработано диалоговым окном приложения, меню или окном приложения.

WH_SHELL - Вызывается, когда создаются и разрушаются окна верхнего уровня или когда приложению-оболочке требуется стать активным.

2. lpfn - указатель на саму hook функцию. Ее заголовок:

 function HOOKFUNCTION(code: Integer; wparam: WPARAM;
     lparam: LPARAM): LRESULT stdcall;
 

Значения входящих параметров зависят от типа hook'a. Если ставится глобальный hook, эта функция должна обязательно находиться в dll.

3. hmod - принимает значение hInstance или дескриптор DLL (в глобальных ловушках).

4. dwThreadId - идентифицирует поток, в который вставляется ловушка. В глобальных hook'ах этот параметр должен быть равен 0.

Для удаления установленной ловушки существует функция UnhookWindowsHookEx(). В качестве параметра нужно использовать указатель (дескриптор) на hook функцию (значение, которое возвращает функция SetWindowsHookEx()).

Ну вот и все, с основами мы ознакомлены. Теперь напишем маленькую шуточную программу, ставящую hook на считывания сообщений мыши (WH_MOUSE). Сделаем так, чтобы при нажатии на правую кнопку мыши скрывалась кнопка "Пуск", при нажатии на левую - появлялась, среднею - изменялся заголовок активного окна. Сама hook функция будет находиться в dll. Кроме того, в dll будут находиться две процедуры - sethook() и removehook(), соответственно устанавливающие и удаляющие ловушку.

Привожу код dll библиотеки:


 library lib;
 
 uses
   windows,messages;
 var
   H : THandle;
 
 {Hook-функция}
 function hook(c0de, wParam, lParam : integer): Lresult; stdcall;
 {Объявления переменных}
 var
   w : THandle;
   hw : hwnd;
 begin
 {Если c0de не меньше 0, все в порядке, продолжаем}
 if c0de >= 0 then
 begin
   { Если wParam = WM_RBUTTONUP, т.е. нажата правая кнопка мыши, получаем
   хендл (handle) кнопки "Пуск" и скрываем ее }
   case wParam of
 WM_RBUTTONUP :
 begin
   W:= FindWindow('Shell_TrayWnd', nil);
   W:= FindWindowEx(W, HWND(0),'Button', nil);
   ShowWindow(W, SW_hide);
 end;
 { Если wParam = WM_LBUTTONUP, т.е. нажата левая кнопка мыши, получаем
 хендл кнопки пуск и показываем ее }
 WM_LBUTTONUP:
 begin
   W:= FindWindow('Shell_TrayWnd', nil);
   W:= FindWindowEx(W, HWND(0),'Button', nil);
   ShowWindow(W, SW_SHOW);
 end;
 { Если wParam = WM_MBUTTONUP, т.е. нажата средняя кнопка мыши, получаем
 указатель на заголовок активного окна и изменяем его }
 WM_MBUTTONUP:
 begin
   hw:=GetForegroundWindow;
   SetWindowText(hw,'EXAMPLE OF WINDOWS HOOK (WH_MOUSE) - by Dark Lord
 <darklord@smtp.ru>');
 end;
 end;
 end else
 {Если c0de меньше 0}
 begin
   {Вызываем следующую ловушку в цепочке ловушек Windows и выходим из процедуры}
   result := CallNextHookEx(H, c0de, wParam, lParam);
   exit;
 end;
 {Вызываем следующую ловушку в цепочке ловушек Windows}
 result := CallNextHookEx(H, c0de, wParam, lParam);
 End;
 
 
 { Процедура установки ловушки, если не удалось
 установить - выводим сообщение об ошибке }
 procedure sethook;
 begin
 H:= SetWindowsHookEx(WH_MOUSE, @hook, hInstance, 0);
 if H = 0 then
   messagebox(0,'hmmm..','ERROR',mb_iconhand);
 end;
 
 { Процедура удаления ловушки }
 procedure removehook;
 begin
   UnhookWindowsHookEx(H);
 end;
 
 { Экспорт процедур установки и удаления hook'a }
 exports
 sethook index 1  name 'sethook',
 removehook index 2 name 'removehook';
 end.
 
 

В самой программе ловушка будет устанавливаться вызовом из dll процедуры sethook, удаляться - вызовом процедуры removehook. Пример установки и удаления hook'а и исходник dll библиотеки есть в прилагающемся исходнике. В данной статье были рассмотрены только основы установки ловушек. Есть немалое количество нюансов и возникающих проблем при установке нескольких hook'ов, установки hook'ов в разных ОС (особенно это касается глобальных ловушек). Для получения подробностей по этим вопросам рекомендую использовать Win32 API Reference или MSDN (если нет диска с MSDN - прогуляйтесь на http://msdn.microsoft.com, здесь правда не вся информация, но большая ее часть).




Как присвоить значение свойству Selected в ListBox

Свойство "selected" компонента ТListBox может быть использованно только если свойство MultiSelect установленно в True. Если Вы работаете с ListBox'ом у которого MultiSelect=false то используйте свойство ItemIndex.


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ListBox1.Items.Add('1');
   ListBox1.Items.Add('2');
   {This will fail on a single selection ListBox}
   // ListBox1.Selected[1] := true;
   ListBox1.ItemIndex := 1; {This is ok}
 end;
 




Как перевести монитор в режим stand-by

Автор: Kecvin S. Gallagher

В офисе два программиста беседуют:
Первый:
- У меня самый матовый монитор!!!
Второй:
- Это потому, что его неоднократно покрывали матом!!!

Если монитор поддерживает режим Stand by, то его можно программно перевести в этот режим. Данная возможность доступна на Windows95 и выше.

Чтобы перевести монитор в режим Stand by:


 SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, 0);
 

Чтобы вывести его из этого режима:


 SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, -1);
 

А теперь более полный пример кода:

На новую форму поместите кнопку, таймер и ListBox.

Timer (use Object Inspector):

Enabled := False
Interval := 15000

Добавьте следующее событие таймеру:


 procedure TForm1.Timer1Timer(Sender: TObject);
 begin
   ListBox1.Items.Add(FormatDateTime('h:mm:ss AM/PM', Time));
   SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, -1);
 end;
 

Command Button:


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ListBox1.Items.Add('--> ' + FormatDateTime('h:mm:ss AM/PM', Time));
   Timer1.Enabled := not Timer1.Enabled;
   SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, 0);
 end;
 

После запуска откомпилированного приложения и нажатия на кнопку, экран погаснет на 15 секунд.

ЗАМЕЧАНИЕ: Удостоверьтесь, что во первых компьютер поддерживает режимы энергосбережения, а вовторых, эти функции не запрещены на данном компьютере.




Позиционирование в TRichEdit и TMemo при нажатии Enter как в предыдущей строке

Вопрос в службу поддержки: Что делать если я довел мышку до края коврика, а курсор не дошел до края экрана?


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, ComCtrls;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     Button2: TButton;
     RichEdit1: TRichEdit;
     procedure RichEdit1KeyPress(Sender: TObject; var Key: Char);
   private
     { Private declarations }
   public
     { Public declarations }
 end;
 
 var
   Form1: TForm1;
 
 implementation
 {$R *.DFM}
 
 uses
   richedit;
 
 procedure TForm1.RichEdit1KeyPress(Sender: TObject; var Key: Char);
 var
   line, col, indent: integer;
   S: string;
 begin
   if key = #13 then
   begin
     key := #0;
     with sender as TRichEdit do
     begin
       {figure out line and column position of caret}
       line := PerForm( EM_EXLINEFROMCHAR, 0, SelStart );
       Col := SelStart - Perform( EM_LINEINDEX, line, 0 );
       {get part of current line in front of caret}
       S:= Copy( lines[ line ], 1, col );
       {count blanks and tabs in this string}
       indent := 0;
       while (indent < length( S )) and (S[indent + 1] in [' ', #9]) do
         Inc( indent );
       {insert a linebreak followed by the substring of blanks and tabs}
       SelText := #13#10 + Copy(S, 1, indent);
     end;
   end;
 end;
 
 end.
 




Как установить количество точек на дюйм в TPrinter

При смене принтера, размер шрифтов может отмасштабироваться не правильно. Чтобы сделать правильное масштабирование, необходимо установить свойство PixelsPerInch шрифта.

Не делайте изменений после того, как принтер начал печатать.

Два примера:


 uses Printers;
 
 var
   MyFile: TextFile;
 begin
   Printer.PrinterIndex := 2;
   AssignPrn(MyFile);
   Rewrite(MyFile);
   Printer.Canvas.Font.Name := 'Courier New';
   Printer.Canvas.Font.Style := [fsBold];
   Printer.Canvas.Font.PixelsPerInch :=
     GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSY);
   Writeln(MyFile, 'Print this text');
   System.CloseFile(MyFile);
 end;
 


 uses Printers;
 
 begin
   Printer.PrinterIndex := 2;
   Printer.BeginDoc;
   Printer.Canvas.Font.Name := 'Courier New';
   Printer.Canvas.Font.Style := [fsBold];
   Printer.Canvas.Font.PixelsPerInch :=
     GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSY);
   Printer.Canvas.Textout(10, 10, 'Print this text');
   Printer.EndDoc;
 end;
 




Публикование свойств-наборов

...я думаю, что ваша проблема заключается в том, что любые поля или методы, которые явно не отнесены ни к одному из типов защиты, автоматически принимают тип published. Я подозреваю, что ваш код должен выглядеть примерно так:


 myClass = class(TComponent)
   private { !! вы пропустили эту директиву защиты }
     fMySetProperty : myset;
   published
     MySetProperty : myset read fMySetProperty write fMySetProperty;
 end;
 




Как указать максимальный размер текста для RichEdit Control

У этого компонента есть свойство MaxLength, которое работает некорректно. Поэтому лучше пользоваться


 RichEdit.Perform(EM_LIMITTEXT, нужный размер, 0);
 

Причем перед каждом открытии файла это действие необходимо повторять.

Если Вы передаете в качестве размера 0, то ОС ограничивает размер OS Specific Default Value. Реально, по результатам моих экспериментов, поставить можно размер, чуть меньший доступной виртуальной памяти. Я ограничился 90% от свободной виртуалки.

Для того, чтобы не повторять этот вызов (EM_LIMITTEXT), можно воспользоваться сообщением EM_EXLIMITTEXT.




Как установить системную дату и время программно

Билл Гейтс собрал Microsoft на конференцию и говорит:
- Господа, мы установили, что половина людей использующих Windows имеет возраст больше медианного! Другая потрясающая новость - это то, что другая половина людей имеет возраст ниже медианного!
- Простите, что такое медианный возраст?
- Этого мы еще не установили.

Следующие несколько строк кода позволяют установить системную дату и время без использования панели управления. Дата и время устанавливаются двумя раздельными компонентами TDateTimePicker. Дата и время декодируются и передаются в API функцию.

Из значения часа вычитается 2 для установки правильного времени.


 procedure TfmTime.btnTimeClick(Sender: TObject);
 var
   vsys: _SYSTEMTIME;
   vYear, vMonth, vDay, vHour, vMin, vSec, vMm: Word;
 begin
   DecodeDate( Trunc(dtpDate.Date), vYear, vMonth, vDay );
   DecodeTime( dtpTime.Time, vHour, vMin, vSec, vMm );
   vMm := 0;
   vsys.wYear := vYear;
   vsys.wMonth := vMonth;
   vsys.wDay := vDay;
   vsys.wHour := ( vHour - 2 );
   vsys.wMinute := vMin;
   vsys.wSecond := vSec;
   vsys.wMilliseconds := vMm;
   vsys.wDayOfWeek := DayOfWeek( Trunc(dtpDate.Date) );
   SetSystemTime( vsys );
 end;
 




Выставление и сброс битов

SetWord - слово, которое необходимо установить. BitNum - номер бита, который необходимо выставить согласно определениям в секции const (Bit0, Bit1 и др...). GetBitStat возвращает Истину, если бит установлен и Ложь в противном случае.


 { Слово записывается следующим образом...            }
 
 { Слово      -  0  0  0  0  0  0 0 0 0 0 0 0 0 0 0 0 }
 { Номер бита - 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 }
 
 const
   Bit0 = 1;
   Bit1 = 2;
   Bit2 = 4;
   Bit3 = 8;
   Bit4 = 16;
   Bit5 = 32;
   Bit6 = 64;
   Bit7 = 128;
 
   Bit8 = 256;
   Bit9 = 512;
   Bit10 = 1024;
   Bit11 = 2048;
   Bit12 = 4096;
   Bit13 = 8192;
   Bit14 = 16384;
   Bit15 = 32768;
 
 procedure SetBit(SetWord, BitNum: Word);
 begin
   SetWord := SetWord or BitNum; { Устанавливаем бит }
 end;
 
 procedure ClearBit(SetWord, BitNum: Word);
 begin
   SetWord := SetWord or BitNum; { Устанавливаем бит }
   SetWord := SetWord xor BitNum; { Переключаем бит   }
 end;
 
 procedure ToggleBit(SetWord, BitNum: Word);
 begin
   SetWord := SetWord xor BitNum; { Переключаем бит   }
 end;
 
 function GetBitStat(SetWord, BitNum: Word): Boolean;
 begin
   GetBitStat := SetWord and BitNum = BitNum { Если бит установлен }
 end;
 




Установить метку тома файловой системы


 BOOL SetVolumeLabel(
     LPCTSTR lpRootPathName,     // адрес имени корневой директории тома
     LPCTSTR lpVolumeName        // метка тома
    );
 

Параметры

lpRootPathName – указывает на завершающуюся нулем строку, определяющую корневую директорию тома файловой системы, метка которого будет устанавливаться. Если значение этого параметра равно NULL, используется корень текущей директории.

lpVolumeName – указывает на строку, определяющую метку тома. Если значение этого параметра равно NULL, то функция удаляет метку указанного тома.

Возвращаемые значения

В случае успеха возвращается ненулевое значение.
В случае неудачи возвращается нуль. Для получения дополнительной информации об ошибке вызовите функцию GetLastError.

См. также: GetVolumeInformation.




Обратиться к колонке или строке StringGrid по заголовку

В следующем примере приведены две функции: GetGridColumnByName() и GetGridRowByName(), которые возвращают колонку или строку, имеющую заданный заголовок (caption).

Пример:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   StringGrid1.Rows[1].Strings[0] := 'This Row';
   StringGrid1.Cols[1].Strings[0] := 'This Column';
 end;
 
 function GetGridColumnByName(Grid: TStringGrid; ColName: string): integer;
 var
   i: integer;
 begin
   for i := 0 to Grid.ColCount - 1 do
     if Grid.Rows[0].Strings[i] = ColName then
     begin
       Result := i;
       exit;
     end;
   Result := -1;
 end;
 
 function GetGridRowByName(Grid: TStringGrid; RowName: string): integer;
 var
   i: integer;
 begin
   for i := 0 to Grid.RowCount - 1 do
     if Grid.Cols[0].Strings[i] = RowName then
     begin
       Result := i;
       exit;
     end;
   Result := -1;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   Column: integer;
   Row: integer;
 begin
   Column := GetGridColumnByName(StringGrid1, 'This Column');
   if Column = -1 then
     ShowMessage('Column not found')
   else
     ShowMessage('Column found at ' + IntToStr(Column));
   Row := GetGridRowByName(StringGrid1, 'This Row');
   if Row = -1 then
     ShowMessage('Row not found')
   else
     ShowMessage('Row found at ' + IntToStr(Row));
 end;
 




Затенить компонент


 procedure ShadeIt(f: TForm; c: TControl; Width: Integer; Color: TColor);
 var
   rect: TRect;
   old: TColor;
 begin
   if (c.Visible) then
   begin
     rect := c.BoundsRect;
     rect.Left := rect.Left + Width;
     rect.Top := rect.Top + Width;
     rect.Right := rect.Right + Width;
     rect.Bottom := rect.Bottom + Width;
     old := f.Canvas.Brush.Color;
     f.Canvas.Brush.Color := Color;
     f.Canvas.fillrect(rect);
     f.Canvas.Brush.Color := old;
   end;
 end;
 
 procedure TForm1.FormPaint(Sender: TObject);
 var
   i: Integer;
 begin
   for i := 0 to Self.ControlCount - 1 do
     ShadeIt(Self, Self.Controls[i], 3, clBlack);
 end;
 




Перетасовка экрана

Системные и прикладные программисты едут на конференцию. Встречаются у касс вокзала, где и те и другие берут билеты. Прикладники покупают по билету на нос, системщики берут один билет. Удивленные прикладники спрашивают:
- У вас че только один человек едет?
- Да нет. Все.
- А как же вы?
- А это наши трудности.
В поезде прикладники занимают места согласно купленных билетов за полчаса до отправления. За 45 сек. До отхода появляется стая системщиков. С криками <Мы товарища провожаем> вся толпа врывается в вагон закрывается в туалете. Поезд трогается. Контроллер подходит к туалету и стучит. Высовывается рука, протягивает билет. Через некоторое время системщики, как тараканы, расползаются по поезду. Едут обратно. Опять встречаются на вокзале. Прикладники, укравшие копирайт берут один билет. Системщики билета не берут. За 45 сек до отхода врывается толпа прикладников и запирается в туалете. Поезд трогается. Стук в дверь туалета. Выосвывается рука, протягивает билет. Системщик хватает билет и бежит в другой туалет.

В статье описывается пример, который позволяет разделить экран на блоки, а затем поменять эти блоки местами. Так же можно менять размеры блоков и скорость их перемещения. На мой взгляд неплохое начало для создания логической игрушки либо экранной заставки.

Уверен, что каждый из Вас уже хоть раз видел что-то подобное в действии. При запуске, программа берёт изображение десктопа и разделяет его на определённое количество прямоугольных частей (одинакового размера). После этого часть блоков случайным образом перемещается со своего первоначального места.

Как это всё осуществить

Создайте новый проект Delphi с чистой формой. Установите свойство Name в 'Shuffler'. Добавьте на форму компоненты Image (Image1) и Timer (Timer1). Image будет содержать в себе изображение десктопа (разобранное), а Timer будет вызывать процедуру рисования. Свойство Interval компонента Timer определяет, как часто будет происходить перемешивание (значение 1000 эквивалентно одной секунде, 2000 - двум секундам).

Так же для проекта потребуется несколько глобальных переменных. Поместите следующий код перед секцией implementation в модуле формы:


 var
   Shuffler: TShuffler; //это было добавлено самим Delphi
 
   DesktopBitmap : TBitmap;
   gx, gy : Integer;
   redRect : TBitmap;
   rW, rH : Integer;
 
 const
   DELTA = 8; //должно быть 2^n
 

Значение константы (integer) DELTA определяет, на сколько частей будет разбит экран (строк и колонок). Число DELTA должно быть в виде 2^n, где n - целое (integer) число со знаком. Большое значение DELTA приводит к маленьким размерам блоков. Например, если DELTA равна 16 и разрешение экрана 1024 x 768, то экран будет поделён на 256 частей размером 64x48.

DesktopBitmap
это битмап, который хранит в себе захваченное текущее изображение десктопа - мы будем получать это изображение делая скриншот.
redRect
это битмап картинка, которая заменяет перемещённую часть картинки. redRect создаётся в событии формы OnCreate.
gx, gy
содержат текущие координаты x и y (Left, Top) redRect внутри разобранного изображения.
rW, rH
это ширина и высота прямоугольного блока. Для 1024x768 и DELTA=16, rW будет равно 64 а rH = 48.

Проект начинает выполняться с обработчика события OnCreate:


 procedure TShuffler.FormCreate(Sender: TObject);
 begin
   rW := Screen.Width div DELTA;
   rH := Screen.Height div DELTA;
 
   redRect:=TBitmap.Create;
   with redRect do
   begin
     Width := rW;
     Height := rH;
     Canvas.Brush.Color := clRed;
     Canvas.Brush.Style := bssolid;
     Canvas.Rectangle(0,0,rW,rH);
     Canvas.Font.Color := clNavy;
     Canvas.Font.Style := Canvas.Font.Style + [fsBold];
     Canvas.TextOut(2,2,'About');
     Canvas.Font.Style := Canvas.Font.Style - [fsBold];
     Canvas.TextOut(2,17,'Delphi');
     Canvas.TextOut(2,32,'Programming');
   end;
 
   Timer1.Enabled := False;
   Image1.Align := alClient;
   Visible := False;
   BorderStyle := bsNone;
   Top := 0;
   Left := 0;
   Width := Screen.Width;
   Height := Screen.Height;
   InitScreen;
   // SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE + SWP_NOMOVE);
   Visible := True;
   Timer1.Interval := 10; // меньше := быстрее
   Timer1.Enabled := True; // Запускаем вызов DrawScreen
 end;
 

Во-первых, значения rW и rH определяются значением DELTA. Как уже объяснялось, если разрешение экрана 800x600 и DELTA равна 8, изображение экрана будет разделено на 8x8 частей размером 100x75 (rW = 100, rH = 75).

Во-вторых, созданный битмап redRect, будет размещён внутри картинки, с той целью, чтобы заменить перемещённый блок. redRect является простым красным прямоугольником с текстом (синим) внутри него. Так же для этого можно использовать готовую эмблему или что-то ещё.

Наконец, устанавливается ширина и высота формы как у экрана. Вызов (закомментированный) API функции SetWindowPos можно использовать, чтобы установить форму всегда на переднем плане (OnTop), не перемещаемую и не изменяемую. Вызывается процедура InitScreen. Устанавливает интервал таймера и начинает выполняться обработчик события OnTimer, запуская процедуру DrawScreen.

InitScreen - Скриншот

Процедура InitScreen, вызываемая из обработчика события OnCreate, используется для получения скриншота текущего изображения десктопа, устанавливая начальную позицию redRect и рисуя сетку. Код, который будет рисовать сетку необязателен.

Чтобы получить скриншот десктопа, используется GetDC для GetDesktopWindow. API функция BitBt используется для передачи картинки десктопа в DesktopBitmap. GetDC(GetDesktopWindow) получает дескриптор контекста устройства дисплея для указанного окна - окна возвращённого функцией GetDesktopWindow. В заключении DesktopBitmap ассоциируется с компонентой Image1. Если что-то не ясно, то советую заглянуть справичные файлы по Delphi.

Начальная позиция redRect выбирается случайным образом. Trunc(Random * DELTA) возвращает целое число от 0 до DELTA. Далее, redRect рисуется в точке gx, gy, используя функцию CopyRect объекта Canvas. Опять же, если Вы не знакомы с алгоритмом рисования Delphi, то советую порыться в справке.

В конце, при помощи MoveTo и LineTo рисуется сетка. Сетка необязательна и используется только для того, чтобы лучше различать границы блоков.


 procedure InitScreen;
 var
   i, j: integer;
 begin
   //получаем битмап десктопа
   DesktopBitmap := TBitmap.Create;
   with DesktopBitmap do
   begin
     Width := Screen.Width;
     Height := Screen.Height;
   end;
   BitBlt(DesktopBitmap.Canvas.Handle,
   0,0,Screen.Width,Screen.Height,
   GetDC(GetDesktopWindow),0,0,SrcCopy);
 
   Shuffler.Image1.Picture.Bitmap := DesktopBitmap;
 
   //изначальные координаты redRect
   Randomize;
   gx := Trunc(Random * DELTA);
   gy := Trunc(Random * DELTA);
 
   Shuffler.Image1.Canvas.CopyRect(
   Rect(rW * gx, rH * gy, rW * gx + rW, rH * gy + rH),
   redRect.Canvas,
   Rect(0,0,rW,rH));
 
   //рисуем сетку
   for i:=0 to DELTA-1 do
   begin
     Shuffler.Image1.Canvas.MoveTo(rW * i,0);
     Shuffler.Image1.Canvas.LineTo(rW * i,Screen.Height);
 
     Shuffler.Image1.Canvas.MoveTo(0, rH * i);
     Shuffler.Image1.Canvas.LineTo(Screen.Width, rH * i);
   end;
 end;
 

Draw Screen

Основной код находится в процедуре DrawScreen. Эта процедура вызывается внутри события OnTimer компонента Timer.


 procedure DrawScreen;
 var
   r1, r2: TRect;
   Direction: integer;
 begin
   r1:=Rect(rW * gx , rH * gy, rW * gx + rW , rH * gy + rH);
 
   Direction := Trunc(Random*4);
   case Direction of
     0: gx := Abs((gx + 1) mod DELTA); //право
     1: gx := Abs((gx - 1) mod DELTA); //лево
     2: gy := Abs((gy + 1) mod DELTA); //низ
     3: gy := Abs((gy - 1) mod DELTA); //верх
   end; //case
 
   r2 := Rect(rW * gx , rH * gy, rW * gx + rW , rH * gy + rH);
 
   with Shuffler.Image1.Canvas do
   begin
     CopyRect(r1, Shuffler.Image1.Canvas, r2);
     CopyRect(r2, redRect.Canvas, redRect.Canvas.ClipRect);
   end;
 end;
 

Несмотря на кажущуюся сложность кода, он очень прост в использовании. Менять местами можно только части смежные с redRect, поэтому доступны только 4 возможных направления. Прямоугольник r1 содержит текущию позицию redRect, r2 указывает на прямоугольник с блоком, который был перемещён. CopyRect используется для перемещения выбранного блока на место redRect и рисования redRect его в новом месте - таким образом осуществляется обмен этих двух блоков.

Было бы приятней наблюдать анимированный обмен блоков, но я оставлю эту задачу для самостоятельного решения.

Не забудьте по событию OnTimer для компонента Timer написать:


 DrawScreen;
 




Разделяемые элементы управления для Tabbednotebook

Вы могли бы получить тот же эффект, устанавливая элементы управления на панели или в другом контейнере, который не является дочерним по отношению к Notebook, но находится наверху. Поскольку элементы не являются дочерними по отношению к страницам, то их никак не затронет изменение страниц, и вы можете управлять ими из кода. Видимость же такова, что кажется, что каждая страница компонента содержит тот же самый набор компонентов.

Что делаю я -- располагаю разделяемые элементы управления на форме, а не на конкретной странице TTabbedNotebook. Для того, чтобы сделать это, вам необходимо установить свойство TTabbedNotebook Align на что-то другое, отличное от alClient -- например, если разделяемые элементы управления расположены в нижней части формы, используйте для TTabbedNotebook значение alTop, и отодвиньте нижнюю границу чуть повыше, чтобы в образовавшейся области без труда разместились бы разделяемые элементы управления.

Если вы хотите сделать так, чтобы "разделяемые" элементы управления имитировали свое нахождение на каждой странице TTabbedNotebook, оставьте их на форме, но поместите их на передний план, и передвиньте TTabbedNotebook снова в нижнюю часть формы.

У меня это работает. Я еще не испытывал нужду в разделяемых элементах управления для _набора_ страниц, но первая идея, которая приходит мне в голову, заключается в установке свойства Visible для каждого компонента в true/false в обработчике события TTabbedNotebook OnChange.




Разделяемые элементы управления для Tabbednotebook 2

Вероятно, самым лучшим решением будет размещение разделяемых компонентов непосредственно на форме, и дальнейшее их перемещение в коде на TabbedNotebook, тем самым делая их видимыми на нескольких страницах компонента.

Для любых закладок, где разделяемые компоненты НЕ должны появляться, установите их свойство Visible в False, сделать это лучше всего в обработчике события TabbedNotebook OnChange.




Разделяемые элементы управления для Tabbednotebook 3

Компоненты, которые вы хотите показывать на всех страницах, должны принадлежать родителю TTabbedNotebook (в общем случае TForm, на которой расположен компонент), и, очевидно, они должны быть размещены ПОЗАДИ TTabbedNotebook. Самым простым способом сделать это, как я выяснил, является следующий способ: разместите на форме TTabbedNotebook, но оставьте возможность задать ему родителя (например, пока не устанавливайте ему свойство .Align), затем разместите кнопки (или что там у вас) в области родителя, затем установите свойство .Align у TTabbedNotebook, после чего элементы управления, которые вы разместили, окажутся позади TTabbedNotebook, и будут видны на всех его страницах (действительно, они будут располагаться "наверху" TTabbedNotebook. Если вы уже разместили компоненты, то лучшим решением будет использование для TTabbedNotebook команды меню "Edit/Send to Back", при котором нижние компоненты "всплывут" наверх. Также, возможно непосредственно отредактировать файл .DFM и убедиться в том, что родительский порядок компонентов собледен в полной мере.




Защита программ перекрытием кода

Автор: Den is Com

Хакеры взломали 3-х минутную демо-версию Виагры. Теперь она trial-версия на 70 дней.

Не секрет, что совершенной защиты не существует, как некоторые авторы и фирмы не пыжатся , но они не правы. Хорошая защита должна обеспечить такой уровень, чтобы на вскрытие защиты нужно было затратить усилия сравнимые с самостоятельным написанием программы. Разумеется она должна быть многоуровневой и перекрывающейся (т.е уровни должны работать независимо). Не забывайте, что хорошие взломщики неплохо знают ассемблер и высокоуровневе ухищрения от них не спасают. Следовательно защищаться нужно тоже используя ассемблер.Не считайте, что это уже не модно или тяжело. Хороший программист не брезгует ассемблером и высшей математикой.

Мой любимый метод для наколки - это перекрывающийся код. Он может показаться немного сложным для большинства из нас, но зная нескольо HEX-значений инструкций процессора,вы тоже сможете сделать небольшой по размеру перекрывающийся код. Перекрывающийся код можно сделать сколь угодно многоуровневым, просто здесь я покажу только в каком направлении надо "копать".


 temp_string :='Den is Com';
 asm
   mov  ax,$05EB
   @as: jmp @as-2
 end;
 ShowMessage('Сообщение');
 

На первый взгляд это может сконфузить вас, но все это очень просто. Первая инструкция заносит "левое" значение в AX. Вторая делает переход на значение операнда команды MOV AX. '05EB' переводится как 'jmp$+5' (помните, что слова хранятся задом наперед) Этот переход перепрыгивает первый JMP и продолжает дальше по коду.Вероятно, не будет достаточно для защиты, но продемонстрирует технику. Взгляните на это как пример.

присваивание temp_string :='Den is Com' существенной роли не играет :), но может использоваться при отладке программы - хорошо присматривается при использовании дизассемблера. Скорее всего ваши первые шаги будут приводить к частому зависанию компьютера, но не отчаивайтесь - это того стоит. Попробуйте разработать свой способ сравнения строк (чаше всего ловятся именно эти инструкции), попробуйте замаскировать инструкции зависания компьютера и т.д.




Как расшарить диск

Автор: Repairman

Программист, глядя на только что отформатированный вирусом винчестер: "Хмм... кажется здесь кто-то поработал зубной щеткой Reach Interdental от Johnson&Johnson..."

Это модуль для Share любого диска или папки как на локальном, так и на удаленном компьютере (если, конечно у Вас права администратора и на компе разрешено удаленное администрирование, для локальной машины это не обязательно... ;-))

Следует отметить, что под NT некоторые процедуры находятся в других DLL...

Функция SetShareOnDisk - ставит шару, RemoveShareFromDisk - снимает ее.


 //(c)2002  repairman@uzel.ru
 unit Share;
 
 interface
 
 type
   TPassw = string[8];
   TNetName = string[12];
 
   function SetShareOnDisk(HostName: string; { имя компьютера }
   LocalPath: string; { папка которую надо открыть для доступа }
   NetName: TNetName; { имя расшаренной папки в сети }
   Remark: string;    { комментарий, видимый в сети }
   Access: word;      { доступ }
   RO_Passw: TPassw;  { пароль на чтение }
   RW_Passw: TPassw   { пароль на полный доступ }
   ): boolean;
 
   function RemoveShareFromDisk(HostName: string; { имя компьютера }
   NetName: string;  { сетевое имя папки которую надо закрыть }
   LocalPath: string { локальный путь папки }
   ): boolean;
 
 var
   ShareResult: word;
 
 implementation
 
 uses
   SysUtils, Windows, ShlObj;
 
 { указатель на имя компьютера,
 например '\\Server'#0, если свой, то можно nil }
 function NetShareAdd(ServerName: PChar;
 Level: Word;       { уровень структуры Share_info, здесь 50 }
 PShareInfo: PChar; { указатель на структуру Share_Info }
 ParmErr: DWord)    { указатель на ??? }
 { svrapi для Win9X, NetApi32 для NT }
 : dword; stdcall; external 'svrapi.dll';
 
 function NetShareDel(ServerName: PChar; NetName: PChar;
 Reserved: DWord): dword; stdcall; external 'svrapi.dll';
 
 type
   _share_info_50 = record { структура Share уровня 50 }
   NetName: array[1..13] of char; { Как будет называться диск в сети }
   SType: byte;   { тип =0 (STYPE_DISKTREE) - шарить диски }
   Flags: word;   { флаги $0191,$0192,$0193....(доступ из сети) }
   Remark: PChar; { указатель на комментарий, видимый из сети }
   Path: PChar;   { указатель на имя ресурса, например 'c:\'#0 }
   { пароль для полного доступа, если не нужен =#0 }
   RW_Password: array [1..9] of char;
   { пароль для доступа на чтение, если не нужен =#0 }
   RO_Password: array [1..9] of char;
 end;
 
 function SetShareOnDisk(HostName, LocalPath: string; NetName: TNetName;
 Remark: string; Access: word; RO_Passw, RW_Passw: TPassw): boolean;
 var
   ShareInfo: _Share_Info_50;
 begin
   Result:=false;
   StrPCopy(@ShareInfo.NetName, NetName);
   ShareInfo.SType:=0;
   ShareInfo.Flags:=Access;
   ShareInfo.Remark:=PChar(Remark);
   ShareInfo.Path:=PChar(LocalPath);
   StrPCopy(@ShareInfo.RO_Password, RO_Passw);
   StrPCopy(@ShareInfo.RW_Password, RW_Passw);
   { вызываем Share }
   ShareResult:=NetShareAdd(PChar(HostName), 50,@ShareInfo,$0000002a);
   if ShareResult<>0 then { расшарить неудалось }
     Exit;
     { сказать шеллу об изменениях }
   SHChangeNotify(SHCNE_NETSHARE, SHCNF_PATH, PChar(LocalPath), nil);
   Result:=true;
 end;
 
 function RemoveShareFromDisk(HostName, NetName, LocalPath: string): boolean;
 begin
   Result:=false;
   { удалить шару }
   ShareResult:=NetShareDel(PChar(HostName), PChar(NetName), 0);
   if ShareResult<>0 then
     Exit;
     { сказать шеллу об изменениях }
   SHChangeNotify(SHCNE_NETUNSHARE, SHCNF_PATH,PChar(LocalPath),nil);
   Result:=true;
 end;
 
 end.
 




Общий доступ к памяти, распределенной DLL

Общий доступ к области отображения файлов (Sharing Memory Mapped Files)... Проверьте нижеследующий код:


 var
 
   HMapping: THandle;
   PMapData: Pointer;
 
 const
 
   MAPFILESIZE = 1000;
 
 procedure OpenMap;
 var
 
   llInit: Boolean;
   lInt: Integer;
 begin
 
   HMapping := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0, MAPFILESIZE,
     pchar('ИМЯ ОБЛАСТИ ОТОБРАЖЕНИЯ'));
   // Проверка наличия
   llInit := (GetLastError() <> ERROR_ALREADY_EXISTS);
   if (hMapping = 0) then
   begin
     ShowMessage('Невозможно создать объект отображения файла');
     Application.Terminate;
     exit;
   end;
   PMapData := MapViewOfFile(HMapping, FILE_MAP_ALL_ACCESS, 0, 0, 0);
   if PMapData = nil then
   begin
     CloseHandle(HMapping);
     ShowMessage('Невозможно отобразить блок памяти');
     Application.Terminate;
     exit;
   end;
   if (llInit) then
   begin
     // Если объект отображения создан, инициализируем блок символами #0
     memset(PMapData, #0, MAPFILESIZE);
   end;
 end;
 
 procedure CloseMap;
 begin
 
   if PMapData <> nil then
   begin
     UnMapViewOfFile(PMapData);
   end;
   if HMapping <> 0 then
   begin
     CloseHandle(HMapping);
   end;
 end;
 
 { Таким образом любые два или более приложения или DLL могут получить указатели к
   одному и тому же блоку памяти.В данном примере PMapData указывает на 1000 -
   байтный буфер, инициализированный вначале символами #0.Однако существует одна
   потенциальная проблема - синхронизация доступа к памяти.Решить эту проблему можно
   с помощью мьютексов.Вот пример их использования:
 
   Вызовите LockMap перед записью (и чтением?) объекта отображения файла.
 Не забывайте после каждого обновления немедленно вызывать UnlockMap. }
 
 var
 
   HMapMutex: THandle;
 
 const
 
   REQUEST_TIMEOUT = 1000;
 
 function LockMap: Boolean;
 begin
 
   Result := true;
   HMapMutex := CreateMutex(nil, false, pchar('ИМЯ ВАШЕГО МЬЮТЕКСА'));
   if HMixMutex = 0 then
   begin
     ShowMessage('Не могу создать мьютекс');
     Result := false;
   end
   else
   begin
     if WaitForSingleObject(HMapMutex, REQUEST_TIMEOUT) = WAIT_FAILED then
     begin
       // время ожидания
       ShowMessage('Невозможно заблокировать объект отображения файла');
       Result := false;
     end;
   end;
 end;
 
 procedure UnlockMap;
 begin
 
   ReleaseMutex(HMixMutex);
   CloseHandle(HMixMutex);
 end;
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS