Как вызвать функцию винапи в любом (но лучше борланд) Паскале?

[Ivanhoe75]

Как вызвать функцию винапи в любом (но лучше борланд) Паскале?

[Федосеев Павел]

На FPC я делал так - там подключается модуль Windows, иногда его не хватало и я стал подключать какой-то модуль из Jedi (это библиотека).

{$mode objfpc}{$H+}
{$smartlink on}
{$APPTYPE GUI}
 
{
System Metrics Display program No. 1
(c) Charlie Petzold, 1996
 
Ported on FPC by !!FPA!! 20/01/2009
}
 
{                                       // !!FPA!! 20/01/2009
  Базовая программа для изучения экранных возможностей Win API.
  Выводит в окне в три колонки системную информацию.
  Строк много и они не все умещаются в окне.
}
 
PROGRAM SysMets1;
 
USES
  Windows,
  _SysMets;
 
FUNCTION WndProc (v_hWnd, v_iMsg : LongWord;
                  v_wParam, v_lParam : LongInt):LongInt; stdcall;
CONST
  cxChar      : Integer   = 0;
  cxCaps      : Integer   = 0;
  cyChar      : Integer   = 0;
VAR
  szBuffer    : String;
  v_hDC       : HDC;
  i           : Integer;
  ps          : PAINTSTRUCT;
  tm          : TEXTMETRIC;
BEGIN
  case v_iMsg of
    WM_CREATE   :
      begin
        v_hDC:=GetDC(v_hWnd);
 
        GetTextMetrics(v_hDC, tm);
        cxChar:=tm.tmAveCharWidth;
        // cxCaps=(tm.tmPitchAndFamily & 1 ? 3 : 2) * cxChar / 2
        if (tm.tmPitchAndFamily AND $1)<>0
          then cxCaps:=(3*cxChar) div 2     // proportional font
          else cxCaps:=cxChar;              // mono font
        cyChar:=tm.tmHeight+tm.tmExternalLeading;
 
        ReleaseDC(v_hWnd, v_hDC);
 
        Result:=0;
        Exit;
      end;
    WM_PAINT    :
      begin
        v_hDC:=BeginPaint(v_hWnd, ps);
 
        for i:=0 to NUMLINES-1 do begin
          TextOut(
            v_hDC,
            cxChar,
            cyChar*(1+i),
            SysMetrics[i].szLabel,
            StrLen(SysMetrics[i].szLabel)
          );
 
          TextOut(
            v_hDC,
            cxChar+22*cxCaps,
            cyChar*(1+i),
            SysMetrics[i].szDesc,
            StrLen(SysMetrics[i].szDesc)
          );
 
          SetTextAlign(v_hDC, TA_RIGHT OR TA_TOP);
 
                                        // !!FPA!! 20/01/2009
// wsprintf (Win API) - не поддерживается в полном виде в FPC 2.2.2
 
(*
          TextOut(
            v_hDC,
            cxChar+22*cxCaps+40*cxChar,
            cyChar*(1+i),
            PChar(szBuffer),
            wsprintf(
              PChar(szBuffer),
              '%5d',
              GetSystemMetrics(SysMetrics[i].iIndex)
            )
          );
*)
          Str(GetSystemMetrics(SysMetrics[i].iIndex),szBuffer);
          TextOut(
            v_hDC,
            cxChar+22*cxCaps+40*cxChar,
            cyChar*(1+i),
            PChar(szBuffer),
            Length(szBuffer)
          );
          SetTextAlign(v_hDC, TA_LEFT OR TA_TOP);
        end;
        EndPaint(v_hWnd, ps);
        Result:=0;
        Exit;
      end;
    WM_DESTROY  :
      begin
        PostQuitMessage(0);
        Result:=0;
        Exit;
      end;
  end;
  Result:=DefWindowProc(v_hWnd, v_iMsg, v_wParam, v_lParam);
END;
 
 
 
CONST
  szAppName   : String = 'SysMets1';
 
VAR
  v_hWnd      : HWND;
  v_Msg       : MSG;
  v_WndClass  : WNDCLASSEX;
 
  v_hInstance : HWND;                   // !!FPA!! 20/01/2009
  v_iCmdShow  : LongInt;                // !!FPA!! 20/01/2009
 
BEGIN
  v_hinstance:=GetModuleHandle(nil);
  with v_WndClass do begin
    cbSize        := SizeOf(v_WndClass);
    Style         := CS_HREDRAW OR CS_VREDRAW;
    lpfnWndProc   := @WndProc;
    cbClsExtra    := 0;
    cbWndExtra    := 0;
    hInstance     := v_hInstance;
    hIcon         := LoadIcon(0, IDI_APPLICATION);
    hCursor       := LoadCursor(0, IDC_ARROW);
    hbrBackground := HBRUSH( GetStockObject(WHITE_BRUSH) );
    lpszMenuName  := nil;
    lpszClassName := PChar(szAppName);
    hIconSm       := LoadIcon(0, IDI_APPLICATION);
  end;
 
  RegisterClassEx(v_WndClass);
 
  v_hWnd:=CreateWindow(
    PChar(szAppName),
    'Get System Metrics No. 1',
    WS_OVERLAPPEDWINDOW,
    CW_USEDEFAULT,
    CW_USEDEFAULT,
    CW_USEDEFAULT,
    CW_USEDEFAULT,
    0,
    0,
    v_hInstance,
    nil
  );
 
  v_iCmdShow:=SW_SHOW;
  ShowWindow(v_hWnd, v_iCmdShow);
  UpdateWindow(v_hWnd);
 
  while GetMessage(v_Msg, 0, 0, 0) do begin
    TranslateMessage(v_Msg);
    DispatchMessage (v_Msg);
  end;
  Halt(v_Msg.wParam);
END.

{$mode objfpc}{$H+}
{$smartlink on}
{
Unit for System Metrics Display program No. 1
(c) Charlie Petzold, 1996
 
Ported on FPC by !!FPA!! 20/01/2009
}
 
UNIT _SysMets;
 
INTERFACE
 
USES
  Windows;
 
CONST
  NUMLINES    = 45-0;              // !!FPA!! 20/01/2009
 
  SM_RESERVED1= 24;                // !!FPA!! 20/01/2009
  SM_RESERVED2= 25;                // !!FPA!! 20/01/2009
  SM_RESERVED3= 26;                // !!FPA!! 20/01/2009
  SM_RESERVED4= 27;                // !!FPA!! 20/01/2009
TYPE
  TSysmetric  = RECORD
    iIndex    : LongInt;
    szLabel   : PChar;
    szDesc    : PChar;
  END;
  TSysmetrics = array [0..NUMLINES-1] of TSysMetric;
CONST
  SysMetrics  : TSysmetrics =
  (
{00}( iIndex  : SM_CXSCREEN;
      szLabel : 'SM_CXSCREEN';
      szDesc  : 'Screen width in pixels'),
{01}( iIndex  : SM_CYSCREEN;
      szLabel : 'SM_CYSCREEN';
      szDesc  : 'Screen height in pixels'),
{02}( iIndex  : SM_CXVSCROLL;
      szLabel : 'SM_CXVSCROLL';
      szDesc  : 'Vertical scroll arrow width'),
{03}( iIndex  : SM_CXHSCROLL;
      szLabel : 'SM_CXHSCROLL';
      szDesc  : 'Horizontal scroll arrow width'),
{04}( iIndex  : SM_CYCAPTION;
      szLabel : 'SM_CYCAPTION';
      szDesc  : 'Caption bar height'),
{05}( iIndex  : SM_CXBORDER;
      szLabel : 'SM_CXBORDER';
      szDesc  : 'Windows border width'),
{06}( iIndex  : SM_CYBORDER;
      szLabel : 'SM_CYBORDER';
      szDesc  : 'Windows border height'),
{07}( iIndex  : SM_CXDLGFRAME;
      szLabel : 'SM_CXDLGFRAME';
      szDesc  : 'Dialog window frame width'),
{08}( iIndex  : SM_CYDLGFRAME;
      szLabel : 'SM_CYDLGFRAME';
      szDesc  : 'Dialog window frame height'),
{09}( iIndex  : SM_CYVTHUMB;
      szLabel : 'SM_CYVTHUMB';
      szDesc  : 'Vertical scroll thumb height'),
{10}( iIndex  : SM_CXHTHUMB;
      szLabel : 'SM_CXHTHUMB';
      szDesc  : 'Horizontal scroll thumb height'),
{11}( iIndex  : SM_CXICON;
      szLabel : 'SM_CXICON';
      szDesc  : 'Icon width'),
{12}( iIndex  : SM_CYICON;
      szLabel : 'SM_CYICON';
      szDesc  : 'Icon height'),
{13}( iIndex  : SM_CXCURSOR;
      szLabel : 'SM_CXCURSOR';
      szDesc  : 'Cursor width'),
{14}( iIndex  : SM_CYCURSOR;
      szLabel : 'SM_CYCURSOR';
      szDesc  : 'Cursor heght'),
{15}( iIndex  : SM_CYMENU;
      szLabel : 'SM_CYMENU';
      szDesc  : 'Menu bar height'),
{16}( iIndex  : SM_CXFULLSCREEN;
      szLabel : 'SM_CXFULLSCREEN';
      szDesc  : 'Full screen client area width'),
{17}( iIndex  : SM_CYFULLSCREEN;
      szLabel : 'SM_CYFULLSCREEN';
      szDesc  : 'Full screen client area height'),
{18}( iIndex  : SM_CYKANJIWINDOW;
      szLabel : 'SM_CYKANJIWINDOW';
      szDesc  : 'Kanji window height'),
{19}( iIndex  : SM_MOUSEPRESENT;
      szLabel : 'SM_MOUSEPRESENT';
      szDesc  : 'Mouse present flag'),
{20}( iIndex  : SM_CYVSCROLL;
      szLabel : 'SM_CYVSCROLL';
      szDesc  : 'Vertical scroll arrow heght'),
{21}( iIndex  : SM_CXHSCROLL;
      szLabel : 'SM_CXHSCROLL';
      szDesc  : 'Horizontal scroll arrow width'),
{22}( iIndex  : SM_DEBUG;
      szLabel : 'SM_DEBUG';
      szDesc  : 'Debug version flag'),
{23}( iIndex  : SM_SWAPBUTTON;
      szLabel : 'SM_SWAPBUTTON';
      szDesc  : 'Mouse button swapped flag'),
                                   // !!FPA!! 20/01/2009
{24}( iIndex  : SM_RESERVED1;
      szLabel : 'SM_RESERVED1';
      szDesc  : 'Reserved'),
{25}( iIndex  : SM_RESERVED2;
      szLabel : 'SM_RESERVED2';
      szDesc  : 'Reserved'),
{26}( iIndex  : SM_RESERVED3;
      szLabel : 'SM_RESERVED3';
      szDesc  : 'Reserved'),
{27}( iIndex  : SM_RESERVED4;
      szLabel : 'SM_RESERVED4';
      szDesc  : 'Reserved'),
 
{28}( iIndex  : SM_CXMIN;
      szLabel : 'SM_CXMIN';
      szDesc  : 'Minimum window width'),
{29}( iIndex  : SM_CYMIN;
      szLabel : 'SM_CYMIN';
      szDesc  : 'Minimum window height'),
{30}( iIndex  : SM_CXSIZE;
      szLabel : 'SM_CXSIZE';
      szDesc  : 'Minimize/Maximize icon width'),
{31}( iIndex  : SM_CYSIZE;
      szLabel : 'SM_CYSIZE';
      szDesc  : 'Minimize/Maximize icon height'),
{32}( iIndex  : SM_CXFRAME;
      szLabel : 'SM_CXFRAME';
      szDesc  : 'Window frame width'),
{33}( iIndex  : SM_CYFRAME;
      szLabel : 'SM_CYFRAME';
      szDesc  : 'Window frame heiht'),
{34}( iIndex  : SM_CXMINTRACK;
      szLabel : 'SM_CXMINTRACK';
      szDesc  : 'Minimum window tracking width'),
{35}( iIndex  : SM_CYMINTRACK;
      szLabel : 'SM_CYMINTRACK';
      szDesc  : 'Minimum window tracking height'),
{36}( iIndex  : SM_CXDOUBLECLK;
      szLabel : 'SM_CXDOUBLECLK';
      szDesc  : 'Double click x tolerance'),
{37}( iIndex  : SM_CYDOUBLECLK;
      szLabel : 'SM_CYDOUBLECLK';
      szDesc  : 'Double click y tolerance'),
{38}( iIndex  : SM_CXICONSPACING;
      szLabel : 'SM_CXICONSPACING';
      szDesc  : 'Horizontal icon spacing'),
{39}( iIndex  : SM_CYICONSPACING;
      szLabel : 'SM_CYICONSPACING';
      szDesc  : 'Vertical icon spacing'),
{40}( iIndex  : SM_MENUDROPALIGNMENT;
      szLabel : 'SM_MENUDROPALIGNMENT';
      szDesc  : 'Left or right menu drop'),
{41}( iIndex  : SM_PENWINDOWS;
      szLabel : 'SM_PENWINDOWS';
      szDesc  : 'Pen extensions installed'),
{42}( iIndex  : SM_DBCSENABLED;
      szLabel : 'SM_DBCSENABLED';
      szDesc  : 'Double-Byte Char Set enabled'),
{43}( iIndex  : SM_CMOUSEBUTTONS;
      szLabel : 'SM_CMOUSEBUTTONS';
      szDesc  : 'Number of mouse buttons'),
{44}( iIndex  : SM_SHOWSOUNDS;
      szLabel : 'SM_SHOWSOUNDS';
      szDesc  : 'Present sounds visually')
  );
 
IMPLEMENTATION
 
END.

[Ivanhoe75]

Что-то не компилируется в fp 2.6.4

Добавлено 20.05.15, 12:17
сообщение 'Cant find unit system used by sysmets'.

[Ivanhoe75]

А в БП ошибка на {37}.

[Федосеев Павел]

БП может не знать о константах, появившихся позднее.

FPC затрудняюсь - т.к. модуль system должен всегда находится.

Бывают какие-то проблемы, вызванные UAC, я уже забыл какие, т.к. после установки FPC кое-что делаю рефлексорно:
1. Отключаю UAC. Перегружаюсь.
2. Настраиваю IDE, help, конфигурационные файлы компилятора и IDE (fpc.cfg, fp.cfg), если нужно - пути к юнитам.
3. Копирую файлы
fp.ans
fp.cfg
fpc.cfg
fp.dsk
fp.ini
в папку "C:\Users\ИмяПользователя\AppData\Roaming\fp\"
4. Включаю UAC. Перегружаюсь.
5. Проверяю переменную окружения Path на предмет наличия в ней пути к папке \bin, и если нет - добавляю. Теперь могу вызывать fp и fpc в любой папке.

[Ivanhoe75]

Прозондировал я вопрос и оказалось, что ни winexec ни shellexecute в паскалевском винапи не поддерживаются. Буду копать Дельфи.