Получение всех шрифтов системы

← →
Alexis © (2006-11-20 17:27) [0]

Добрый вечер!
Есть код, который должен компилироваться 16-битным BP v7.0 и сохранять структуры шрифтов в массив InstFonts. Вот как это работало на Delphi6
var fontCount : Integer; InstFonts : array of TLogFont; function EnumFontsProc(var lf : TLogFont; var tm : TTextMetric; fontType : Longint; param : PInteger) : Integer; stdcall; begin Inc(param^); SetLength(InstFonts, fontCount); InstFonts[fontCount - 1] := lf; Freemem(TmpPtr); EnumFontsProc := 1; end; function EnumerateFonts(DC : HDC) : Integer; begin fontCount := 0; EnumFonts(DC, nil, @EnumFontsProc, @fontCount); EnumerateFonts := fontCount; end;

Но в BP v7.0 нет динамич.массисов и ф-ции SetLength, но нужно, чтобы к InstFonts можно бы было обращаться по индексу для получения конкретного шрифта и я переделал код так:
var fontCount : Integer; InstFonts : ^TLogFont; function EnumFontsProc(var lf : TLogFont; var tm : TTextMetric; fontType : Longint; param : PInteger) : Integer; far; var TmpPtr : ^TLogFont; i : Integer; begin Inc(param^); TmpPtr := Pointer(InstFonts); Getmem(InstFonts, fontCount * sizeof(TLogFont)); for i := 0 to fontCount-2 do InstFonts^[i] := TmpPtr^[i]; //!!! InstFonts[fontCount - 1] := lf; Freemem(TmpPtr); EnumFontsProc := 1; end; function EnumerateFonts(DC : HDC) : Integer; begin fontCount := 0; EnumFonts(GetDC(0), nil, @EnumFontsProc, @fontCount); EnumerateFonts := fontCount; end;

Компил.жалуется на помеченную строку:wrong qualifier. Как тут надо изменить, ума не приложу, давно на Pascal не писал.
Заранее спасибо.

← →
MBo © (2006-11-20 17:51) [1]

объяви тип указателя на массив, а не на один элемент.
Кроме того, в обоих вариантах сделано плохо - перераспределение памяти на каждом шагу. Сделай сразу большой массив, с запасом

← →
Alexis © (2006-11-20 18:54) [2]

> Кроме того, в обоих вариантах сделано плохо - перераспределение
> памяти на каждом шагу

Это я знаю, пока сделаю, чтоб просто работало, это академич.задание.

> объяви тип указателя на массив, а не на один элемент.

это как? А разве указатель на память не является по сути массивом? не могли бы пример привести, а то я после 2 лет перерыва C/C++ на Паскале с дикими муками пишу :)
Я пробовал вот так :
InstFonts : ^TLogFont[];
и так
InstFonts : ^(TLogFont[]);

все равно плохо :(

← →
Anatoly Podgoretsky © (2006-11-20 19:37) [3]

> Alexis (20.11.2006 17:27:00) [0]

Под какую ОС то пишешь?

← →
Alexis © (2006-11-20 19:47) [4]

> Anatoly Podgoretsky © (20.11.06 19:37) [3]

Под Win2000, WinXP, но надо, чтобы программа была 16-битной

← →
Leonid Troyanovsky © (2006-11-20 19:49) [5]

> Alexis © (20.11.06 19:47) [4]

> Под Win2000, WinXP, но надо, чтобы программа была 16-битной

Я даже соглашусь думать над этой проблемой.
Но, скажи, ради Бога, а на зачем?

--
Regards, LVT.

← →
Anatoly Podgoretsky © (2006-11-20 19:55) [6]

> Alexis (20.11.2006 19:47:04) [4]

Паскаль под ДОС? А он ничего про Виндоус не знает.

← →
Leonid Troyanovsky © (2006-11-20 20:05) [7]

> Anatoly Podgoretsky © (20.11.06 19:55) [6]

> Паскаль под ДОС? А он ничего про Виндоус не знает.

Мне даже показалось, что ДОС под XP.

--
Regards, LVT.

← →
Alexis © (2006-11-20 21:24) [8]

Leonid Troyanovsky © (20.11.06 19:49) [5]
> Я даже соглашусь думать над этой проблемой

Ловлю на слове! :)

> Но, скажи, ради Бога, а на зачем?

Предмет в универе - Интерактивные системы. Мы на голом API должны написать 16-битную/32-битную GUI програмки на С/Pascal. На С я уже обе версии и на Delphi6 32-битную версию асилил, проблема с pascal 16-бит. Нам нужно компилять это чудо Borland Pascal v7.0, а там разумеется нет ни динамич.массивов, ни SetLength и мне надо эмулировать дин. массив путем выделения памяти Getmem, но с Паскалем давно не работал и путаюсь с указателями.

В общем [0] :)

← →
Alexis © (2006-11-20 21:28) [9]

> Anatoly Podgoretsky © (20.11.06 19:55) [6]
> Паскаль под ДОС? А он ничего про Виндоус не знает

Знает!
program Keylook; uses WinTypes, WinProcs, Strings; function MainWindowProc(hWindow : HWND; msg : Word; wParam : Word; lParam : Longint) : Longint; export; begin ... end; begin FillChar(windowClass, sizeof(TWndClass), 0); windowClass.style := CS_HREDRAW or CS_VREDRAW; windowClass.lpfnWndProc := @MainWindowProc; windowClass.cbClsExtra := 0; windowClass.cbWndExtra := 0; windowClass.hInstance := hInstance; windowClass.hIcon := LoadIcon(0, IDI_APPLICATION); windowClass.hCursor := LoadCursor(0, IDC_ARROW); windowClass.hbrBackground := CreateSolidBrush(GetSysColor(COLOR_BTNFACE)); windowClass.lpszMenuName := NIL; windowClass.lpszClassName := szWndClass; RegisterClass(windowClass); hWindow := CreateWindow(szWndClass, "KeyLook", WS_OVERLAPPEDWINDOW, Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), HWND(nil), HMENU(nil), hInstance, nil ); if (hWindow = 0) then Exit; ShowWindow(hWindow, SW_SHOWNORMAL); UpdateWindow(hWindow); while (GetMessage(message, 0, 0, 0)) do begin TranslateMessage(message); DispatchMessage(message); end; end.

BPC.exe -CW Program.pas

> Alexis © (20.11.06 21:24) [8]

> должны написать 16-битную/32-битную GUI програмки на С/Pascal.
> На С я уже обе версии и на Delphi6 32-битную версию асилил,
> проблема с pascal 16-бит. Нам нужно компилять это чудо
> Borland

Дык, а зачем Pascal v7.0? Достачно D1, IMHO.
Правда, там не было дин. массивов и пр.,
но, достаточно, Getmem vs SetLenght.

Правда, найти сейчас описание нужных функций
в msdn - достаточно нетривиальная задача.

--
Regards, LVT.

> Leonid Troyanovsky © (20.11.06 21:50) [10]

> в msdn - достаточно нетривиальная задача.

Чего-то я утомился.
Если есть описалово для с - давай сюда.
Т.е., проблема - в переводе с->d1.

--
Regards, LVT.

> Если есть описалово для с - давай сюда.
> Т.е., проблема - в переводе с->d1.

int fontCount; static LOGFONT *InstFonts; /*Installed fonts*/ int CALLBACK EnumFontsProc(const LOGFONT *lplf, const TEXTMETRIC *lptm, DWORD dwType, LPVOID lpParam) { fontCount = *((int far *)lpParam); fontCount++; InstFonts = (LOGFONT *)realloc(InstFonts, sizeof(LOGFONT) * fontCount); InstFonts[fontCount - 1] = *lplf; return 1; } int EnumerateFonts(HDC hdc) { fontCount = 0; EnumFonts(hdc, NULL, (FONTENUMPROC)EnumFontsProc, (LPARAM)&fontCount); return (fontCount); }

Перебрать шрифты после вызова EnumerateFonts(GetWindowDC(hWnd)) можно так:

for (int i = 0; i < fontCount; i++)
MessageBox(NULL, InstFonts[i].lfFaceName, "Fonts", MB_OK);

Как перевести в BP7.0 мой сишный код?

> Alexis ©

Вариант - связанный список. Что-то вроде этого (не проверял, возможны ошибки):
type PFontRecord = ^TFontRecord; TFontRecord = record Font: TLogFont; Next: PFontRecord end; var FirstFontRecord: PFontRecord = nil; CurrentFontRecord: PFontRecord; FontCount: Integer = 0; function EnumFontsProc(var LF: TLogFont; var TM: TTextMetric; FontType: Longint; Param: PInteger) : Integer; stdcall; var NewFontRecord: PFontRecord; begin Inc(Param^); New(NewFontRecord); NewFontRecord^.Font := LF; NewFontRecord^.Next := nil; if FirstFontRecord = nil then FirstFontRecord := NewFontRecord else CurrentFontRecord^.Next := NewFontRecord; CurrentFontRecord := NewFontRecord; EnumFontsProc := 1 end; function EnumerateFonts(DC: HDC): Integer; begin EnumerateFonts := EnumFonts(DC, nil, @EnumFontsProc, @FontCount) end; procedure DisposeFontRecords; begin while FirstFontRecord <> nil do begin CurrentFontRecord := FirstFontRecord; FirstFontRecord := FirstFontRecord^.Next; Dispose(CurrentFontRecord) end end;

Получение всех шрифтов системы Найти похожие ветки