На главную Наши проекты:
Журнал   ·   Discuz!ML   ·   Wiki   ·   DRKB   ·   Помощь проекту
ПРАВИЛА FAQ Помощь Участники Календарь Избранное RSS
msm.ru
! user posted image
Пожалуйста, выделяйте текст программы тегом [сode=pas] ... [/сode]. Для этого используйте кнопку [code=pas] в форме ответа или комбобокс, если нужно вставить код на языке, отличном от Дельфи/Паскаля.

Соблюдайте общие правила форума

Следующие вопросы задаются очень часто, подробно разобраны в FAQ и, поэтому, будут безжалостно удаляться:
1. Преобразовать переменную типа String в тип PChar (PAnsiChar)
2. Как "свернуть" программу в трей.
3. Как "скрыться" от Ctrl + Alt + Del (заблокировать их и т.п.)
4. Как запустить программу/файл? (и дождаться ее завершения)
5. Как перехватить API-функции, поставить hook? (перехват сообщений от мыши, клавиатуры - внедрение в удаленное адресное прстранство)
... (продолжение следует) ...

Внимание:
Попытки открытия обсуждений реализации вредоносного ПО, включая различные интерпретации спам-ботов, наказывается предупреждением на 30 дней.
Повторная попытка - 60 дней. Последующие попытки - бан.
Мат в разделе - бан на три месяца...

Полезные ссылки:
user posted image MSDN Library user posted image FAQ раздела user posted image Поиск по разделу user posted image Как правильно задавать вопросы


Выразить свое отношение к модераторам раздела можно здесь: user posted image Rouse_, user posted image Krid

Модераторы: Rouse_, Krid
  
> Простейшее оконное приложение , сделанное на API в Delphi
    Это результат обобщения информации, который мне не удалось самостоятельно поместить в раздел FAQ

    Программа MyClock представляет собой набор примеров:

    1. Регистрация оконного класса
    2. Создание окна со следующими параметрами:
    - без заголовка
    - без кнопки на панели задач
    3. Написание оконной процедуры
    4. Организация перемещения окна мышью
    5. Создание BITMAP в памяти для рисования "в тени"
    6. Очистка BITMAP заданным цветом
    7. Вывод текста с помощью TextOut и DrawText
    6. Копирование содержимого BITMAP в окно программы
    7. Получение времени
    8. Создание дополнительного потока
    ExpandedWrap disabled
       
      program myClock;
       
      (* составил С.Г.Можаровский (c) 2004 by sw <a class='tag-url' href='http://sw.newmail.ru/' target='_blank'>http://sw.newmail.ru/</a>            *)
      (* программа которая демонстрирует создание простейшего окна средствами API *)
       
      uses  Windows, Messages;
       
      const WinClassNm = 'myClockWin';
       
      var
      (*-------------------------------*)
      (*     окно программы myClock    *)
        hWinClock  : HWnd;  (* handle окна                                       *)
        hWinParent : HWnd;  (* handle parent - окна для WinClock                 *)
        AMessage   : TMsg;  (* переменная для цикла сбора сообщений для WinClock *)
        x0,y0      : integer;  (* левый верхний угол окна *)
        w ,h       : integer;  (* ширина и высота окна    *)
       
      (*--------------------------------*)
      (* для перетаскивания окна мышкой *)
        PMSave : TPoint;    (* в PMSave сохраняем абсолютные координаты мыши    *)
       
      (*--------------------------------*)
      (* "теневой" BITMAP в котором     *)
      (*  происходит предварительное    *)
      (*  рисование                     *)
        MemDC  : HDC;       (* здесь рисуем фон и помещаем текст                *)
        MemBMP : HBITMAP;   (* BMP в памяти, к-рое копируется в окно WinClock   *)
       
      (*--------------------------------*)
      (* дополнительный поток           *)
      (*     который следит за временем *)
        ThreadID : cardinal;(* ID потока                                        *)
        hThread  : THandle; (* handle потока                                    *)
        T        : longint; (* глобальная переменная для дополнительного потока *)
       
      (*                                                                        *)
      (*========================================================================*)
      (*                      всё для WindowProc                                *)
      (*                                                                        *)
       
      procedure Win_OnPaint(h:HWnd; var Msg:TWMPaint);
      var
        DC          : HDC;
        PaintStruct : TPaintStruct;
        r           : TRect;
      begin
      (* внутри OnPaint используется BeginPaint вместо GetDC *)
        DC := BeginPaint(h, PaintStruct);
        GetClientRect(h,r);                 (* размер копируемого прямоугольника *)
        BitBlt(DC,0,0,r.Right,r.Bottom,MemDC,0,0,SRCCOPY);  (* команда рисования *)
        EndPaint(h,PaintStruct);            (* собственно рисование              *)
      end;
       
      procedure Win_Move(h:HWnd);
      var dx,dy : integer; r : TRect; PM : TPoint;
      begin
        GetCursorPos(PM);        (* получить абсолютную текущую позицию мыши *)
        dx := PM.X - PMSave.X; dy := PM.Y - PMSave.Y; (* изменения координат *)
        if (dx = 0) and (dy = 0) then Exit;   (* если нет изменений - выйти  *)
        PMSave := PM;            (* запомнить текущую позицию мыши           *)
        GetWindowRect(h,r);      (* выяснить абсолютные координаты окна      *)
        SetWindowPos(h,
              HWND_TOP,          (* оставлять перемещаемое окно наверху      *)
             r.Left+dx,r.Top+dy, (* новые координаты левого верхнего угла    *)
                     0,0,        (* ширину и высоту не задаём, т.к.          *)
             SWP_NOSIZE);        (* т.к. размер окна не меняем               *)
      end;
       
      procedure Win_OnLButtonDown(h:HWnd; var Msg:TWMMouse);
      begin
        GetCursorPos(PMSave); (* получить и запомнить абсолютные координаты мыши *)
        SetCapture(h);        (* "захватить" мышь окном h                        *)
      end;
       
      procedure Win_OnLButtonUp(h:HWnd; var Msg:TWMMouse);
      begin
        ReleaseCapture; (* освободить захват мыши окном *)
        Win_Move(h);    (* последний сдвиг окна         *)
      end;
       
      procedure Win_OnMouseMove(h:HWnd; var Msg:TWMMouse);
      begin
        if (Msg.Keys and MK_LBUTTON) = 1  (* если удерживается левая кнопка мыши *)
        then Win_Move(h);                 (* то сдвинуть окно                    *)
      end;
       
      (* собственно оконная процедура *)
      function Win_WindowProc(h: HWnd; AMessage, WParam, LParam: Longint): Longint;
        stdcall; export;
      var aMsg : TMessage absolute AMessage;
      begin
        Win_WindowProc := 0;
      (*   инструкция "absolute" позволяет обойтись без присваиваний :
        AMsg.Msg    := AMessage;
        aMsg.WParam := WParam;
        aMsg.LParam := LParam;
        aMsg.Result := 0;
      *)
        case AMessage of
          wm_Destroy: begin PostQuitMessage(0); Exit; end;
          wm_Paint       : Win_OnPaint      (h,TWMPaint(aMsg));
          wm_MouseMove   : Win_OnMouseMove  (h,TWMMouse(aMsg));
          wm_LButtonDown : Win_OnLButtonDown(h,TWMMouse(aMsg));
          wm_LButtonUp   : Win_OnLButtonUp  (h,TWMMouse(aMsg));
      //  wm_KeyDown     : Win_OnKeyDown
        end; (* case *)
       
        Win_WindowProc := DefWindowProc(h, AMessage, WParam, LParam);  (* Default *)
      end;
       
       
      (*            clock  WindowProc                                            *)
      (*=========================================================================*)
       
      (*=========================================================================*)
      (* регистрируем Window Class окна программы                                *)
       
      function Clock_WinRegister: Boolean;
      var WindowClass: TWndClass;
          Instance   : integer;
      begin
        Instance := Windows.GetModuleHandle(nil);
        WindowClass.Style         := cs_hRedraw or cs_vRedraw; (* перерисовывать *)
        WindowClass.lpfnWndProc   := @Win_WindowProc;
        WindowClass.cbClsExtra    := 0;        (* доп память к окну      *)
        WindowClass.cbWndExtra    := 0;        (* - '' -                 *)
        WindowClass.hInstance     := Instance; (* или SysInit.HInstance; *)
        WindowClass.hIcon         := 0;        (* или LoadIcon(0, idi_Application); *)
        WindowClass.hCursor       := LoadCursor(0, IDC_ARROW);  (* или 0 *)
        WindowClass.hbrBackground := HBrush(COLOR_BACKGROUND); // COLOR_WINDOW
        WindowClass.lpszMenuName  := nil;
        WindowClass.lpszClassName := WinClassNm;
       
        Result := RegisterClass(WindowClass) <> 0;
      end;
       
      (*------------------------------------------------------------------------*)
      (*                                   утилитки                             *)
       
      procedure Waiting(ms:integer);(* используется вместо Sleep, не загружает проц.*)
      var h : THandle;
      begin
        h := CreateEvent(nil,true,false,'');
        WaitForSingleObject(h,ms);
        CloseHandle(h);
      end;
       
      (* перевод числа N в строку из D цифр с ведущими нулями *)
      function NumStr(N,D:integer):string;
      var S : string;
      begin Str(N,S); while length(S) < D do S := '0'+S; Result := S; end;
       
       
      (* переводит SystemTime (тики) в строку *)
      function MyTimeToStr(T:TSystemTime):string;
      begin
        with T do Result :=
          NumStr(wYear,4)  + '-' + NumStr(wMonth,2) + '-' + NumStr(wDay,2)   + ' ' +
          NumStr(wHour,2)  + ':' + NumStr(wMinute,2)+ ':' + NumStr(wSecond,2);
      end;
       
      (* создаёт BMP в памяти ("в тени"), на котором будем МЕДЛЕННО рисовать *)
      (* и, затем, результаты рисования БЫСТРО бросать в видимое окно        *)
      (*   в конце работы окна созданные теневые BMP и DC надо будет удалить *)
      procedure GetMemBMP(var DC:HDC;var BMP:HBITMAP;w,h:integer);
      var
        hWndCompatible : HWnd; (* handle Окна рабочего стола    *)
        hDCCompatible  : HDC;  (* handle DC Окна рабочего стола *)
      begin
        hWndCompatible := GetDesktopWindow;      (* handle Окна рабочего стола *)
      //hWndCompatible := 0;                     (* handle Окна всего экрана   *)
        hDCCompatible  := GetDC(hWndCompatible); (* handle Дисплей-Контекста   *)
        MemDC  := CreateCompatibleDC(hDCCompatible);
        MemBMP := CreateCompatibleBitmap(hDCCompatible,w,h);(*w,h=ширина,высота BMP*)
        SelectObject(MemDC,MemBMP);              (* связываем BMP и DC             *)
        ReleaseDC(hWndCompatible,hDCCompatible); (* DC Compatible больше не нужен  *)
                                              (* WndCompatible освобождать не надо *)
      end;
       
      (* для очистки поля вывода заданным цветом *)
      procedure FillRectByColor(DC:HDC;r:TRect;Color:COLORREF);
      var hBr,hBr0 : HBRUSH;
      begin
        hBr  := CreateSolidBrush(Color);
        hBr0 := SelectObject(MemDC,hBr);
        FillRect(DC,r,hBr);
        SelectObject(DC,hBr0);
        DeleteObject(hBr);
      end;
       
      (*                                   утилитки                             *)
      (*------------------------------------------------------------------------*)
       
      (*========================================================================*)
      (*                       всё для TreadProc                                *)
      (*                                                                        *)
       
      (* BMP перерисовывается, если время (секунды) изменилось *)
      procedure BMPReFresh;
      var
        r : TRect;
        S : string;
        T : TSystemTime;
        C : COLORREF;
      begin
        r.Left := 0; r.Right := w; r.Top := 0; r.Bottom := h;
        C := RGB(255,0,0);
      //C := GetBkColor(MemDC); (* не работает, фон всегда получается белый *)
        FillRectByColor(MemDC,r,C);
       
        GetLocalTime(T);
        S := MyTimeToStr(T);
       
        SetBkMode(MemDC,TRANSPARENT);
        (* процедура вывода текста из модуля GDI                       *)
        (* параметры - шрифт, точка привязки символов к опорной точке  *)
        (* цвет текста, цвет или прозрачность фона заданы в DC         *)
        TextOut(MemDC,10,10,PChar(S),length(S));
       
        (* процедура вывода текста из модуля USER32                    *)
        (* вместо длины строки можно записать -1,                      *)
        (*                            если строка нуль-терминированная *)
        (* кроме параметров, которые действуют и для TextOut можно ещё *)
        (* задать выравнивание текста относительно прямоугольника r    *)
        DrawText(MemDC,PChar(S),{-1}length(S),
                 r, DT_SINGLELINE or DT_CENTER or DT_VCENTER);
      end;
       
      function AnotherThreadProc(Data : Integer) : Integer; stdcall;
      begin
        Result := 0;
        repeat
      //  GetClientRect(hClock,r);
          if T <> GetCurrentTime then begin
            T := GetCurrentTime;
            BMPReFresh;                           (* пора обновить картинку     *)
            InvalidateRect(hWinClock,nil,false);  (* nil - весь прямоугольник   *)
      //    InvalidateRect(hWinClock,@r,true);    (* r - заданный прямоугольник *)
          end;
          Waiting(55);   // = Sleep(55);
        until false;
      (* т.к. выход из repeat не достигается, следущая строка не нужна *)
      //PostMessage(hWinClock,wm_Destroy,0,0);
      end;
       
      (*============================================================================*)
      (*============================================================================*)
      (*============================================================================*)
       
      Begin
       
      (*=========== регистрируем оконный класс ====================*)
        if not Clock_WinRegister then begin
          MessageBox(0, 'Windows Register failed', nil, mb_Ok);
          Exit;
        end;
       
      (*=========== создаём окно ====================*)
       
        w  := 300; h  := 100;    (* задаём размеры и    *)
        x0 :=   0; y0 :=   0;    (* начальное положение *)
       
        hWinParent := GetDesktopWindow; (* handle окна DeskTop      *)
      //hWinParent := 0;                (* handle окна всего экрана *)
        hWinClock :=
        CreateWindowEx(
         WS_EX_TOOLWINDOW    (* - без кнопки на панели задач *)
      // or WS_EX_CLIENTEDGE (* - модифицирует рамку (Bound) *)
         or WS_EX_TOPMOST,   (* - поверх всех окон           *)
         WinClassNm,         (* имя оконного класса          *)
         '',                 (* Title - имя окна             *)
         WS_POPUP          (* $8000 0000    - без заголовка окна            *)
         or WS_BORDER      (* $0080 0000    - тоненькая рамка цвета Border  *)
      // or WS_CHILD            - ничего в нашем случае не меняет
      // or WS_VISIBLE          - если хотим обойтись без вызова ShowWindow
         ,
         x0,   y0,         (* x0   , y0       cw_UseDefault, cw_UseDefault, *)
         w ,   h ,         (* width, height   cw_UseDefault, cw_UseDefault, *)
         hWinParent,       (* hWndDeskTop или hWndFullScreen                *)
         0,                (* hMenu                                         *)
         hInstance,        (* описатель приложения                          *)
         Nil );            (* address of window-creation data               *)
       
        if hWinClock = 0 then begin
          MessageBox(0, 'WinClock Create failed', nil, mb_Ok);
          Exit;
        end;
       
        ShowWindow(hWinClock, CmdShow);
      //UpdateWindow(hWinClock);    (* обновлять окно будет дополнительный поток *)
       
        GetMemBMP(MemDC,MemBMP,w,h);(* создадим место для рисования "в тени"     *)
       
        (* дополнительный поток -                                      *)
        (*   следит за временем и                                      *)
        (*   заставляет окно перерисовываться, если секунды изменились *)
        hThread := CreateThread(
          nil,                  (* указатель на Security Attributs *)
          0,                    (* начальный размер стека в байтах *)
          @AnotherThreadProc,   (* указатель на Thread - функцию   *)
          nil,                  (* аргумент для нового потока      *)
          0,                    (* флаги создания *)
          ThreadID              (* хранит 32-разрядный ID потока *)
          );
       
      (*--------------------------------------------*)
        (* рабочий цикл основного потока -                           *)
        (* обрабатывает мышь, клавиатуру (процедурой по умолчанию),  *)
        (* перерисовку (OnPaint), которая заключается в копировании  *)
        (* картинки из теневого BMP                                  *)
       
        while GetMessage(AMessage, 0, 0, 0) do begin
          TranslateMessage(AMessage);
          DispatchMessage(AMessage);
        end;
      (*--------------------------------------------*)
       
        CloseHandle(hThread);
       
        DeleteObject(MemBMP);
        DeleteDC(MemDC);
       
        Halt(AMessage.wParam);
      End.


    Компилируется этот проект из командной строки с помощью строчки
    dcc32 -b myclock.dpr


    Источники информации, фрагментов кода при написании MyClock:
    - Ч.Калверт "Энциклопедия Дельфи" (2-е издание)
    - Материалы форума sources.ru
    - Справочная система Delphi
    0 пользователей читают эту тему (0 гостей и 0 скрытых пользователей)
    0 пользователей:


    Рейтинг@Mail.ru
    [ Script execution time: 0,0480 ]   [ 16 queries used ]   [ Generated: 1.10.22, 02:53 GMT ]