VPF::Начался отбор тем для DRKB 3.0 - Форум программистов

Rouse_

Дата 27.9.2006, 22:15 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 469
Регистрация: 23.4.2005

Репутация: 5
Всего: 29

Итак, Виталий Невзоров открывает следующий этап расширения Delphi Russian Knowledge Base .
Что есть DRKB: это самая большая и полная в рунете база знаний по Дельфи, составленная по материалам форумов Vingrad.ru и Sources.ru, а так же других источников. Содержит более 2000 хорошо отклассифицированных и тщательно оформленных статей в формате chm (Windows Help).
Эта база составленна силами профессиональных программистов (и им сочуствующим) для программистов .
Если вы желаете расширить эту базу своим материалом и стать совтором DRKB, то отправляйте Ваши материалы в данную ветку.
Добавление статьи в данную ветку происходит на Вашей доброжелательной основе.
Ваши материалы не рецензируются, но могут редактироваться.
Все статьи будут тщательно анализироваться сообществом модераторов форума и привлеченных извне специалистов по тематике статьи.
Статьи, помещеные в DRKB, обязательно будут иметь указание на автора статьи.
Большая просьба: не пишите по поводу непомещения Вашей статьи в DRKB.
Если она не помещена в DRKB - значит она не прошла проверку на качество подачи материала или уровень изложения.
(Объяснения причин отсутствия статьи не разглашаются)

M
Snowy

Все материалы или линки на них бросаем прямо в этот топ.
(На случай, если кто прочитал, но не заметил)

--------------------

Vae Victis
(Горе побежденным (лат.))
Демо с открытым кодом: http://rouse.drkb.ru

Voyager

Дата 2.10.2006, 07:02 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 532
Регистрация: 8.2.2005

Репутация: 2
Всего: 18

Вот моя функция получения пути до программы из файла ярлыка:

Код


Uses ShlObj, ActiveX;

function IShellLinkGetPath(szFile:string):string;
var
  pSL  : IShellLink;
  pPF  : IPersistFile;
  hRes : HRESULT;
  wsz  : array [0..MAX_PATH] of WideChar;
  szGotPath : array [0..MAX_PATH] of Char;
  pfd: TWin32FindData;
begin
  If not fileexists(szFile) then exit;
  CoInitialize(nil);
  hRes := CoCreateInstance(CLSID_ShellLink,
          nil,
          CLSCTX_INPROC_SERVER,
          IShellLink,
          pSL);
  if SUCCEEDED(hRes) then
    begin
      hRes := pSL.QueryInterface(IPersistFile,pPF);
      if SUCCEEDED(hRes) then
        begin
          StringToWideChar(szFile, wsz, SizeOf(wsz));
          hRes := pPF.Load(wsz, STGM_READ);
          if SUCCEEDED(hRes) then
            begin
              hRes := pSL.GetPath(szGotPath,
                      MAX_PATH,
                      pfd,
                      SLGP_UNCPRIORITY);
              if SUCCEEDED(hRes) then
                result := szGotPath;
            end;
        end;
    end;
  CoUninitialize;
end;

Sunvas

Дата 5.10.2006, 16:19 (ссылка)

(нет голосов)

Загрузка ...

Соль и сахар

Профиль
Группа: Участник
Сообщений: 3388
Регистрация: 12.3.2006
Где: Тосно

Репутация: 28
Всего: 89

Вот мое решение как нарисовать эффект "Муравьи" на форме.
http://forum.vingrad.ru/index.php?showtopi...st&p=693628

--------------------

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

FF90h

Дата 8.10.2006, 13:13 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 72
Регистрация: 1.7.2006
Где: Планета Земля

Репутация: нет
Всего: 1

Смена МАК адреса тестировал на WinXP Prof Sp1 Sp2 WinXp Home

Код


...
uses Registry;
...
var
  Registry: TRegistry;
...
  Registry := TRegistry.Create;
  Registry.RootKey := HKEY_LOCAL_MACHINE;
  Registry.OpenKey('SYSTEM\CurrentControlSet\Control\Class\{4D36E972-E325-11CE-BFC1-08002bE10318}\0008',false);
  Registry.WriteString('NetworkAddress','С0FFE21FС000');
  //С0-FF-E2-1F-С0-00 Новый МАК
  //www.microsoft.com/technet/prodtechnol/windows2000serv/reskit/regentry/85478.mspx
  Registry.CloseKey;
  Registry.Free;
...

Это сообщение отредактировал(а) FF90h - 8.10.2006, 13:46

Sunvas

Дата 9.10.2006, 20:57 (ссылка)

(нет голосов)

Загрузка ...

Соль и сахар

Профиль
Группа: Участник
Сообщений: 3388
Регистрация: 12.3.2006
Где: Тосно

Репутация: 28
Всего: 89

Элементы комбинаторики - размещения, перестановки, сочетания

Вот три функции для вычисления всех возможных вариантов выбора элементов методом сочетания, перестановки и размещения. Где s - строка элементов, k - количество элементов при выборе, povtor - возможность повторения элементов.
Строки, поступающие в эти функции не должны содержать одинаковых символов. Строки, которые содержат одинаковые символы, перед подачей в функцию надо нормализировать при помощи функции normalize;

Код


function sochetanie(s:string;k:word;povtor:boolean):tstrings;
var p:pboolean;
    c:string;
    strlist:tstringlist;
 procedure proced(zn,dl:word);
 var w:integer;
 begin
   for w:=1 to length(s) do
     begin
       if ((p^)and(pos(c[zn-1],s)<=w))or((not p^)and(pos(c[zn-1],s)<w)) then
         begin
            c[zn]:=s[w];
            if zn<dl then proced(zn+1,dl);
            if zn=dl then strlist.Add(c);
         end;
     end;
 end;
begin
strlist:=tstringlist.Create;
strlist.Clear;
if (k=length(s))and(not povtor) then
  begin
    strlist.Add(s);
    result:=strlist;
    exit;
  end;
new(p);
if k<=length(s) then p:=@povtor else p^:=true;
setlength(c,k);
proced(1,k);
result:=strlist;
end;

function razmeschenie(s:string;k:word;povtor:boolean):tstrings;
var p:pboolean;
    c:string;
    strlist:tstringlist;
 procedure proced(zn,dl:word);
 var w:integer;
 begin
    for w:=1 to length(s) do
    if (p^)or((not p^)and(pos(s[w],copy(c,1,zn-1))=0)) then
    begin
        c[zn]:=s[w];
        if zn<dl then proced(zn+1,dl);
        if zn=dl then strlist.Add(c);
    end;
 end;
begin
strlist:=tstringlist.Create;
strlist.Clear;
new(p);
if k<=length(s) then p:=@povtor else p^:=true;
setlength(c,k);
proced(1,k);
result:=strlist;
end;

function perestanovka(s:string):tstrings;
begin
result:=razmeschenie(s,length(s),false);
end;

function normalize(s:string):string;
var ss:string;
     n:longword;
begin
if s='' then
 begin
  result:=s;
  exit;
 end;
n:=1;
ss:=s;
while n<=length(ss) do
  begin
    while pos(ss[n],copy(ss,n+1,length(ss)))>0 do delete(ss,n+pos(ss[n],copy(ss,n+1,length(ss))),1);
    inc(n);
  end;
result:=ss;
end;

И, как последствие из комбинаторики, хочу привести функцию перебора паролей. Где line - строка (символы не должны повторяться), len - длина пароля, minlen - выдать также пароли длиной от 1 до len.

Код


function passwords(const line:string;len:word;minlen:boolean):Tstrings;
var c:string;
    i:word;
    strlist:tstringlist;
 procedure proced(zn,dl:word);
 var w:integer;
 begin
   for w:=1 to length(line) do
   begin
     c[zn]:=line[w];
     if zn<dl then proced(zn+1,dl);
     if zn=dl then strlist.Add(c);
   end;
 end;
begin
strlist:=tstringlist.Create;
strlist.Clear;
if minlen then
   for i:=1 to len do
      begin
        c:='';
        setlength(c,i);
        proced(1,i);
      end
      else begin
        setlength(c,len);
        proced(1,len);
      end;
result:=strlist;
end;

Все применение в прилагаемом файле.
ЗЫ: По вопросам и предложениям пишите в ПМ

Это сообщение отредактировал(а) Sunvas - 7.1.2007, 21:13

Присоединённый файл ( Кол-во скачиваний: 16 )

kombinatorika.zip 2,36 Kb

--------------------

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

Yanis

Дата 13.10.2006, 10:09 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 2937
Регистрация: 9.2.2004
Где: Москва

Репутация: 72
Всего: 111

Добавление иконки в стандартный MessageBox (используется MessageBoxIndirect)

Цитата(Yanis @ 13.10.2006, 00:14)

Код

function MessageBoxIndirect(const MsgBoxParams: TMsgBoxParams): Integer; stdcall; external user32 name 'MessageBoxIndirectA';

function MessageBoxWithIcon(hWnd: HWND; const lpText, lpCaption: string; uType: DWORD; szIcon: PWChar): Integer;
var
  mbp: TMsgBoxParams;
begin
  ZeroMemory(@mbp, SizeOf(mbp));
  with mbp do
    begin
      cbSize := SizeOf(mbp);
      hwndOwner := hWnd;
      hInstance := SysInit.HInstance;
      lpszText := PChar(lpText);
      lpszCaption := PChar(lpCaption);
      PWChar(lpszIcon) := szIcon;
      dwStyle := uType;
    end;

  Result := MessageBoxIndirect(mbp);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  MessageBoxWithIcon(Handle, 'Привет', 'Сообщение с иконкой!', MB_USERICON or MB_APPLMODAL, 'MAINICON');
end;

Добавлено @ 23:16
Пришлось экспортировать функцию MessageBoxIndirectA самостоятельно т.к. в модуле Windows она неправильно объявлена.
Если нет желания импортировать, то можно изменить последнюю строчку функции на такую:

Код

Result := Integer(MessageBoxIndirect(mbp));

http://forum.vingrad.ru/index.php?showtopi...st&p=886953

Добавление собственных компонентов с [B]MessageBox. Другой подход, с использованием ловушек.[/B]

Цитата(Yanis @ 13.10.2006, 10:40)

Цитата(aktuba @ 13.10.2006, 09:59

)

А какие книги посоветуешь? Я, так понимаю, что-то по устройству Windows? Можешь дать названия?

Вот ещё один способ добавления элемента управления в MessageBox:

Код

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  g_hHook: HHOOK;
  g_oldProc: Pointer = nil;
  g_bChecked: Boolean = False;
  g_cb: TCheckBox;
  g_szCbCaption: string = '';

const
  IDC_CHECKBOX = 1000;

implementation

{$R *.dfm}

// узнаём ширину текста для контекста (HDC) определённого окна (hWnd)
function GetTextWidth(hWnd: HWND; const szCaption: string): Integer;
var
  Res: TSize;
begin
  ZeroMemory(@Res, SizeOf(Res));
  GetTextExtentPoint32(GetWindowDC(hWnd), PChar(szCaption), Length(szCaption), Res);
  Result := Res.cx;
end;

function MyMessageBox(hWnd: HWND; const szText, szCaption, szCheckBoxCaption: string; uType: UINT): Integer;
begin
  g_szCbCaption := szCheckBoxCaption;
  Result := MessageBox(hWnd, PChar(szText), PChar(szCaption), uType);
end;

procedure CreateCheckBox(hWndOwner: HWND);
begin
  g_cb := TCheckBox.Create(Application);
  with g_cb do
    begin
      ParentWindow := hWndOwner;
      g_cb.Caption := g_szCbCaption;
      Checked := True;
      g_cb.Width := GetTextWidth(g_cb.Handle, g_szCbCaption);
      SetWindowLong(Handle, GWL_ID, IDC_CHECKBOX);
    end;
end;

procedure UnInstallHook(m_gHook: HHOOK);
begin
    // Uninstall the hook
    UnhookWindowsHookEx(m_gHook);
end;

function SetOut: Boolean;
begin
  g_cb.Checked := not g_cb.Checked;
end;

function HookWndProc(hWnd: HWND; uMsg, wParam, lParam: Integer): Integer; stdcall;
var
  nRc: Integer;
begin
  // дадим ОС обработать основные операции
  nRc := CallWindowProc(g_oldProc, hWnd, uMsg, wParam, lParam);

  // если диалог хочет загрузиться, то...
  if (uMsg = WM_INITDIALOG) then
      begin
      // создаём на нём кнопку
      CreateCheckBox(hWnd);
    end;

  // если кликнули по checkbox-у
  // на это указывает его nID
    if (uMsg = WM_COMMAND) and (wParam = IDC_CHECKBOX) then
    SetOut; // обрабатываем нажатие на checkbox

  // если диалог уничтожается, то...
    if (uMsg = WM_NCDESTROY) then
    begin
        UnInstallHook(g_hHook);
      FreeAndNil(g_cb);
    end;

  Result := nRc;
end;

// функция ловушки нашего приложения
function SetHook(nCode, wParam, lParam: Integer): Integer; stdcall;
var
  M: TCWPStruct;
begin
  if (nCode = HC_ACTION) then
    begin
      M := TCWPStruct(Pointer(lParam)^);

      // если нам пришло сообщение, что сейчас будет создан checkbox, то ....
      if M.message = WM_INITDIALOG then
        g_oldProc := Pointer(SetWindowLong(M.hwnd, GWL_WNDPROC, Integer(@HookWndProc)));
    end;

  Result := CallNextHookEx(g_hHook, nCode, wParam, lParam);
end;

// устанавливаем ловушку на все сообщения, которые
// предназначаются оконной процедуре
// мы будем их обрабатывать перед оконной процедурой
function InstallHook: HHOOK;
begin
    g_hHook := SetWindowsHookEx(WH_CALLWNDPROC,
                              @SetHook, // процедура обработки ловушки
                              0,
                              GetCurrentThreadId()); // ассоциируем ловушку с текущим (потоком нешего окна) потоком
  Result := g_hHook;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  InstallHook;
  MyMessageBox(Handle, 'Исходные данные будут перезаписаны!', 'Продолжить?', 'Больше не предупреждать меня', MB_ICONQUESTION or MB_YESNO)
end;

end.

Изменение расположения CheckBox оставляю на тебя. Заодно и по коду пробежишься. Комменты имеются.

http://forum.vingrad.ru/index.php?showtopi...st&p=887225

Это сообщение отредактировал(а) Yanis - 13.10.2006, 10:17

--------------------

*щёлк*

Akella

Дата 19.10.2006, 13:21 (ссылка)

(нет голосов)

Загрузка ...

Творец

Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 36
Всего: 329

FireBird SQL Server + C#

выборка из одной таблицы

Код


string mySelectQuery = "select a.id, r.name from apart a left join regions r on (r.id = a.id_regions)";
myConnection.Open();
FbDataAdapter da = new FbDataAdapter(mySelectQuery, myConnection);
FbCommand comm = new FbCommand(mySelectQuery);
DataSet ds = new DataSet("regions");
da.Fill(ds, "regions");
DataTable dt = ds.Tables["regions"];
dataGridView1.DataSource = dt;

выборка из двух таблиц

Код


string mySelectQuery = "select a.id, r.name from apart a left join regions r on (r.id = a.id_regions)";
myConnection.Open();
FbDataAdapter da = new FbDataAdapter(mySelectQuery, myConnection);
FbCommand comm = new FbCommand(mySelectQuery);
DataSet ds = new DataSet();
da.Fill(ds);
DataTable dt = ds.Tables[0];
dataGridView1.DataSource = dt;

Snowy

Дата 19.10.2006, 13:28 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Модератор
Сообщений: 11363
Регистрация: 13.10.2004
Где: Питер

Репутация: 192
Всего: 484

Akella, а какое отношение C# имеет к DRKB?

Akella

Дата 19.10.2006, 15:29 (ссылка)

(нет голосов)

Загрузка ...

Творец

Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 36
Всего: 329

Отлавливаем нажатие клавишь в OnKeyDown (кто-то говорил, что в OnKeyDown мона только впоймать только служебные клавиши, типа VK_RETURN или VK_F1)

Код


//отлавливаем Ctrl+F, чтобы включить контекстный поиск грида
//а т.к. может быть не только английская, но и русская раскладка, то нужно отлавливать ещё и русские 'А' и 'а'
//ловим нажатие обеих регистров, т.е. и 'F', и 'f
  if ((ssCtrl in Shift) and (key in [Ord('F'),Ord('f'),Ord('А'),Ord('а')])) then begin
    dbgArrivalDet.OptionsBehavior.IncSearch := true;
    dbgArrivalDet.OptionsBehavior.IncSearchItem := dbgArrivalDet.Controller.FocusedColumn;
  end;
//просто для справки: dbgArrivalDet - cxGrid (DevExpress)

Добавлено @ 15:31
вот это (редактор колонок для DBGridEh)
http://forum.vingrad.ru/index.php?showtopi...st&p=876524

то же самое, только используем контекстные меню
http://forum.vingrad.ru/index.php?showtopi...st&p=885300

Добавлено @ 15:37

Цитата

Akella, а какое отношение C# имеет к DRKB?

да ,точно, не сообоазил чётта что Delphi Rassian Knowlage Base

Это сообщение отредактировал(а) Akella - 19.10.2006, 15:38

Akella

Дата 23.10.2006, 10:56 (ссылка)

(нет голосов)

Загрузка ...

Творец

Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 36
Всего: 329

Работа с колонтитулами в Excel
http://forum.vingrad.ru/act-ST/f-89/t-117773/unread-1.html

Добавлено @ 11:01
Шрифты и цвета в Excel
http://forum.vingrad.ru/act-ST/f-89/t-117775/unread-1.html

Romikgy

Дата 23.10.2006, 11:06 (ссылка)

(нет голосов)

Загрузка ...

Любитель-программер

Профиль
Группа: Участник Клуба
Сообщений: 7326
Регистрация: 11.5.2005
Где: Porto Franco Odes sa

Репутация: 26
Всего: 146

Цитата(Akella @ 19.10.2006, 14:29

)

имхо здесь немного с избыточностью, т.к. в онкейдауне в кее виртуальная кнопка, а она и для больших и для маленьких и вообще для всех раскладок одинакова, вот файлик с инклюдом всех виртуальных кодов ,
использование
добавляем такую вещь
{$I virtual_key.inc}
и юзаем везде по коду VK_RETURN , VK_F

Цитата(Akella @ 19.10.2006, 14:29

)

if ((ssCtrl in Shift) and (key in [Ord('F'),Ord('f'),Ord('А'),Ord('а')])) then begin

и условие для контрл F

Код


if ((ssCtrl in Shift) and (key in [VK_F ])) then begin

или

Код


if ((ssCtrl in Shift) and (key=VK_F )) then begin

Присоединённый файл ( Кол-во скачиваний: 18 )

virtual_key.inc 3,03 Kb

--------------------

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

Akella

Дата 23.10.2006, 11:07 (ссылка)

(нет голосов)

Загрузка ...

Творец

Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 36
Всего: 329

Нраницы и перенос по словам в Excel
http://forum.vingrad.ru/topic-117776.html

TopSergey

Дата 25.10.2006, 23:17 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 1
Регистрация: 25.10.2006

Репутация: нет
Всего: нет

Я слыхал тут отбор тем для нового DRKB. Вот, нашёл интересную вещь. В предыдущих версиях DRKB не встречал.

Называется: Как использовать CHM Help файлы в Delphi.

Код


unit HtmlHelp;

interface

uses
  Windows, Graphics;

const
  HH_DISPLAY_TOPIC = $0000;
  HH_DISPLAY_TOC = $0001;
  HH_DISPLAY_INDEX = $0002;
  HH_DISPLAY_SEARCH = $0003;
  HH_SET_WIN_TYPE = $0004;
  HH_GET_WIN_TYPE = $0005;
  HH_GET_WIN_HANDLE = $0006;
  HH_GET_INFO_TYPES = $0007;
  HH_SET_INFO_TYPES = $0008;
  HH_SYNC = $0009;
  HH_ADD_NAV_UI = $000A;
  HH_ADD_BUTTON = $000B;
  HH_GETBROWSER_APP = $000C;
  HH_KEYWORD_LOOKUP = $000D;
  HH_DISPLAY_TEXT_POPUP = $000E;
  HH_HELP_CONTEXT = $000F;

const
  HHWIN_PROP_ONTOP = 2;
  HHWIN_PROP_NOTITLEBAR = 4;
  HHWIN_PROP_NODEF_STYLES = 8;
  HHWIN_PROP_NODEF_EXSTYLES = 16;
  HHWIN_PROP_TRI_PANE = 32;
  HHWIN_PROP_NOTB_TEXT = 64;
  HHWIN_PROP_POST_QUIT = 128;
  HHWIN_PROP_AUTO_SYNC = 256;
  HHWIN_PROP_TRACKING = 512;
  HHWIN_PROP_TAB_SEARCH = 1024;
  HHWIN_PROP_TAB_HISTORY = 2048;
  HHWIN_PROP_TAB_FAVORITES = 4096;
  HHWIN_PROP_CHANGE_TITLE = 8192;
  HHWIN_PROP_NAV_ONLY_WIN = 16384;
  HHWIN_PROP_NO_TOOLBAR = 32768;

const
  HHWIN_PARAM_PROPERTIES = 2;
  HHWIN_PARAM_STYLES = 4;
  HHWIN_PARAM_EXSTYLES = 8;
  HHWIN_PARAM_RECT = 16;
  HHWIN_PARAM_NAV_WIDTH = 32;
  HHWIN_PARAM_SHOWSTATE = 64;
  HHWIN_PARAM_INFOTYPES = 128;
  HHWIN_PARAM_TB_FLAGS = 256;
  HHWIN_PARAM_EXPANSION = 512;
  HHWIN_PARAM_TABPOS = 1024;
  HHWIN_PARAM_TABORDER = 2048;
  HHWIN_PARAM_HISTORY_COUNT = 4096;
  HHWIN_PARAM_CUR_TAB = 8192;

const
  HHWIN_BUTTON_EXPAND = 2;
  HHWIN_BUTTON_BACK = 4;
  HHWIN_BUTTON_FORWARD = 8;
  HHWIN_BUTTON_STOP = 16;
  HHWIN_BUTTON_REFRESH = 32;
  HHWIN_BUTTON_HOME = 64;
  HHWIN_BUTTON_BROWSE_FWD = 128;
  HHWIN_BUTTON_BROWSE_BCK = 256;
  HHWIN_BUTTON_NOTES = 512;
  HHWIN_BUTTON_CONTENTS = 1024;
  HHWIN_BUTTON_SYNC = 2048;
  HHWIN_BUTTON_OPTIONS = 4096;
  HHWIN_BUTTON_PRINT = 8192;
  HHWIN_BUTTON_INDEX = 16384;
  HHWIN_BUTTON_SEARCH = 32768;
  HHWIN_BUTTON_HISTORY = 65536;
  HHWIN_BUTTON_FAVORITES = 131072;
  HHWIN_BUTTON_JUMP1 = 262144;
  HHWIN_BUTTON_JUMP2 = 524288;
  HHWIN_BUTTON_ZOOM = HHWIN_Button_Jump2 * 2;
  HHWIN_BUTTON_TOC_NEXT = HHWIN_Button_Zoom * 2;
  HHWIN_BUTTON_TOC_PREV = HHWIN_Button_Toc_Next * 2;

const
  HHWIN_DEF_Buttons = HHWIN_Button_Expand or HHWIN_Button_Back or
    HHWIN_Button_Options or HHWIN_Button_Print;

const
  IDTB_EXPAND = 200;
  IDTB_CONTRACT = 201;
  IDTB_STOP = 202;
  IDTB_REFRESH = 203;
  IDTB_BACK = 204;
  IDTB_HOME = 205;
  IDTB_SYNC = 206;
  IDTB_PRINT = 207;
  IDTB_OPTIONS = 208;
  IDTB_FORWARD = 209;
  IDTB_NOTES = 210;
  IDTB_BROWSE_FWD = 211;
  IDTB_BROWSE_BACK = 212;
  IDTB_CONTENTS = 213;
  IDTB_INDEX = 214;
  IDTB_SEARCH = 215;
  IDTB_HISTORY = 216;
  IDTB_FAVORITES = 217;
  IDTB_JUMP1 = 218;
  IDTB_JUMP2 = 219;
  IDTB_CUSTOMIZE = 221;
  IDTB_ZOOM = 222;
  IDTB_TOC_NEXT = 223;
  IDTB_TOC_PREV = 224;

const
  HHN_First = Cardinal(-860);
  HHN_Last = Cardinal(-879);

  HHN_NavComplete = HHN_First - 0;
  HHN_Track = HHN_First - 1;

type
  HHN_Notify = record
    hdr: Pointer;
    pszUrl: PWideChar;
  end;

  HH_Popup = record
    cbStruct: Integer;
    hinst: THandle;
    idString: Cardinal;
    pszText: PChar;
    pt: TPoint;
    clrForeground: TColor;
    clrBackground: TColor;
    rcMargins: TRect;
    pszFont: PChar;
  end;

  HH_AKLINK = record
    cbStruct: Integer;
    fReserved: bool;
    pszKeywords: PChar;
    pszUrl: PChar;
    pszMsgText: PChar;
    pszMsgTitle: PChar;
    pszWindow: PChar;
    fIndexOnFail: bool;
  end;

type
  HHWin_NavTypes = (HHWIN_NAVTYPE_TOC,
    HHWIN_NAVTYPE_INDEX,
    HHWIN_NAVTYPE_SEARCH,
    HHWIN_NAVTYPE_HISTORY,
    HHWIN_NAVTYPE_FAVOURITES);

type
  HH_InfoType = Longint;
  PHH_InfoType = ^HH_InfoType;

type
  HHWin_NavTabs = (HHWIN_NavTab_Top,
    HHWIN_NavTab_Left,
    HHWIN_NavTab_Bottom);

const
  HH_Max_Tabs = 19;

type
  HH_Tabs = (HH_TAB_CONTENTS,
    HH_TAB_INDEX,
    HH_TAB_SEARCH,
    HH_TAB_HISTORY,
    HH_TAB_FAVORITES
    );

const
  HH_FTS_DEFAULT_PROXIMITY = (-1);

type
  HH_FTS_Query = record
    cbStruct: Integer;
    fUniCodeStrings: bool;
    pszSearchQuery: PChar;
    iProximity: Longint;
    fStemmedSearch: bool;
    fTitleOnly: bool;
    fExecute: bool;
    pszWindow: PChar;
  end;

type
  HH_WinType = record
    cbStruct: Integer;
    fUniCodeStrings: bool;
    pszType: PChar;
    fsValidMembers: Longint;
    fsWinProperties: Longint;
    pszCaption: PChar;
    dwStyles: Longint;
    dwExStyles: Longint;
    rcWindowPos: TRect;
    nShowState: Integer;
    hwndHelp: THandle;
    hwndCaller: THandle;
    paInfoTypes: ^HH_InfoType;
    hwndToolbar: THandle;
    hwndNavigation: THandle;
    hwndHTML: THandle;
    iNavWidth: Integer;
    rcHTML: TRect;
    pszToc: PChar;
    pszIndex: PChar;
    pszFile: PChar;
    pszHome: PChar;
    fsToolbarFlags: Longint;
    fNotExpanded: bool;
    curNavType: Integer;
    tabPos: Integer;
    idNotify: Integer;
    TabOrder: array[0..HH_Max_Tabs + 1] of Byte;
    cHistory: Integer;
    pszJump1: PChar;
    pszJump2: PChar;
    pszUrlJump1: PChar;
    pszUrlJump2: PChar;
    rcMinSize: TRect;
  end;

  PHH_WinType = ^HH_WinType;

type
  HHACTTYpes = (HHACT_TAB_CONTENTS,
    HHACT_TAB_INDEX,
    HHACT_TAB_SEARCH,
    HHACT_TAB_HISTORY,
    HHACT_TAB_FAVORITES,

    HHACT_EXPAND,
    HHACT_CONTRACT,
    HHACT_BACK,
    HHACT_FORWARD,
    HHACT_STOP,
    HHACT_REFRESH,
    HHACT_HOME,
    HHACT_SYNC,
    HHACT_OPTIONS,
    HHACT_PRINT,
    HHACT_HIGHLIGHT,
    HHACT_CUSTOMIZE,
    HHACT_JUMP1,
    HHACT_JUMP2,
    HHACT_ZOOM,
    HHACT_TOC_NEXT,
    HHACT_TOC_PREV,
    HHACT_NOTES,

    HHACT_LAST_ENUM
    );

type
  HHNTRACK = record
    hdr: TNMHDR;
    pszCurUrl: PWideChar;
    idAction: Integer;
    phhWinType: ^HH_WinType;
  end;
  PHHNTRACK = ^HHNTRACK;

  HHNNAVCOMPLETE = record
    hdr: TNMHDR;
    pszUrl: PChar;
  end;
  PHHNNAVCOMPLETE = ^HHNNAVCOMPLETE;

type
  THtmlHelpA = function(hwndCaller: THandle; pszFile: PChar;
    uCommand: Cardinal; dwData: Longint): THandle;
  stdCall;
  THtmlHelpW = function(hwndCaller: THandle; pszFile: PChar;
    uCommand: Cardinal; dwData: Longint): THandle;
  stdCall;

function HH(hwndCaller: THandle; pszFile: PChar; uCommand: Cardinal;
  dwData: Longint): THandle;
function HtmlHelpInstalled: Boolean;

implementation

const
  ATOM_HTMLHELP_API_ANSI = #14#0;
ATOM_HTMLHELP_API_UNICODE = #15#0;

var
HtmlHelpA: THtmlHelpA;
  OCXHandle: THandle;

function HH;
begin
  Result := 0;
  if (Assigned(HtmlHelpA)) then
  begin
    Result := HtmlHelpA(hwndCaller, pszFile, uCommand, dwData);
  end;
end;

function HtmlHelpInstalled: Boolean;
begin
  Result := (Assigned(HtmlHelpA));
end;

initialization
  begin
    HtmlHelpA := nil;
    OCXHandle := LoadLibrary('HHCtrl.OCX');
    if (OCXHandle <> 0) then
    begin
      HtmlHelpA := GetProcAddress(OCXHandle, 'HtmlHelpA');
    end;
  end;

finalization
  begin
    if (OCXHandle <> 0) then
      FreeLibrary(OCXHandle);
  end;
end.
//-----------------------------------------------

unit Unit1;

{....}

implementation

uses
  HtmlHelp;

const
  HH_HELP_CONTEXT = $F;
  MYHELP_FILE = 'DualHelp.chm' + Chr(0);
var
  RetCode: LongInt;

{$R *.DFM}

procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if Key = vk_f1 then
  begin
    if HtmlHelpInstalled = True then
    begin
      RetCode := HH(Form1.Handle, PChar(MYHELP_FILE), HH_HELP_CONTEXT,
        ActiveControl.HelpContext);
      Key := 0; //eat it!
    end
    else
      helpfile := 'hhtest.hlp';
  end;
end;

Snowy

Дата 25.10.2006, 23:28 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Модератор
Сообщений: 11363
Регистрация: 13.10.2004
Где: Питер

Репутация: 192
Всего: 484

TopSergey, есть уже.
В разделе "Разработка приложений -> Работа со справочной системой"
Не этот же код, но аналогичный.

Snowy

Дата 26.10.2006, 23:03 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Модератор
Сообщений: 11363
Регистрация: 13.10.2004
Где: Питер

Репутация: 192
Всего: 484

Не знаю, стоит ли одна строчка места в DRKB...
Как определить язык Windows?
То есть какая винда: русская/английская/еврейская etc

Код


function GetSystemDefaultUILanguage: UINT; stdcall; external kernel32 name 'GetSystemDefaultUILanguage';
function GetSysLang: integer;
begin
  result :=   Lo(GetSystemDefaultUILanguage);
end;

Функция GetSysLang возвращает язык системы.
Таблица языков есть в MSDN.
Но на всякий случай привожу тут:

Цитата

00 - LANG_NEUTRAL - Neutral
01 - LANG_ARABIC - Arabic
02 - LANG_BULGARIAN - Bulgarian
03 - LANG_CATALAN - Catalan
04 - LANG_CHINESE - Chinese
05 - LANG_CZECH - Czech
06 - LANG_DANISH - Danish
07 - LANG_GERMAN - German
08 - LANG_GREEK - Greek
09 - LANG_ENGLISH - English
0a - LANG_SPANISH - Spanish
0b - LANG_FINNISH - Finnish
0c - LANG_FRENCH - French
0d - LANG_HEBREW - Hebrew
0e - LANG_HUNGARIAN - Hungarian
0f - LANG_ICELANDIC - Icelandic
10 - LANG_ITALIAN - Italian
11 - LANG_JAPANESE - Japanese
12 - LANG_KOREAN - Korean
13 - LANG_DUTCH - Dutch
14 - LANG_NORWEGIAN - Norwegian
15 - LANG_POLISH - Polish
16 - LANG_PORTUGUESE - Portuguese
18 - LANG_ROMANIAN - Romanian
19 - LANG_RUSSIAN - Russian
1a - LANG_CROATIAN - Croatian
1a - LANG_SERBIAN - Serbian
1b - LANG_SLOVAK - Slovak
1c - LANG_ALBANIAN - Albanian
1d - LANG_SWEDISH - Swedish
1e - LANG_THAI - Thai
1f - LANG_TURKISH - Turkish
20 - LANG_URDU - Urdu
21 - LANG_INDONESIAN - Indonesian
22 - LANG_UKRAINIAN - Ukrainian
23 - LANG_BELARUSIAN - Belarusian
24 - LANG_SLOVENIAN - Slovenian
25 - LANG_ESTONIAN - Estonian
26 - LANG_LATVIAN - Latvian
27 - LANG_LITHUANIAN - Lithuanian
29 - LANG_FARSI - Farsi
2a - LANG_VIETNAMESE - Vietnamese
2b - LANG_ARMENIAN - Armenian
2c - LANG_AZERI - Azeri
2d - LANG_BASQUE - Basque
2f - LANG_MACEDONIAN - FYRO - Macedonian
36 - LANG_AFRIKAANS - Afrikaans
37 - LANG_GEORGIAN - Georgian
38 - LANG_FAEROESE - Faeroese
39 - LANG_HINDI - Hindi
3e - LANG_MALAY - Malay
3f - LANG_KAZAK - Kazak
40 - LANG_KYRGYZ - Kyrgyz
41 - LANG_SWAHILI - Swahili
43 - LANG_UZBEK - Uzbek
44 - LANG_TATAR - Tatar
45 - LANG_BENGALI - Not - supported.
46 - LANG_PUNJABI - Punjabi
47 - LANG_GUJARATI - Gujarati
48 - LANG_ORIYA - Not - supported.
49 - LANG_TAMIL - Tamil
4a - LANG_TELUGU - Telugu
4b - LANG_KANNADA - Kannada
4c - LANG_MALAYALAM - Not - supported.
4d - LANG_ASSAMESE - Not - supported.
4e - LANG_MARATHI - Marathi
4f - LANG_SANSKRIT - Sanskrit
50 - LANG_MONGOLIAN - Mongolian
56 - LANG_GALICIAN - Galician
57 - LANG_KONKANI - Konkani
58 - LANG_MANIPURI - Not - supported.
59 - LANG_SINDHI - Not - supported.
5a - LANG_SYRIAC - Syriac
60 - LANG_KASHMIRI - Not - supported.
61 - LANG_NEPALI - Not - supported.
65 - LANG_DIVEHI - Divehi

Добавлю. Нашёл в DRKB топ "Как определить локализацию ОС: английская или русская?"
Это решение неверное - оно говорит о том, какой язык дефолтный, но не определяет локализацию.
Правильный данный пример smile

Akella

Дата 27.10.2006, 08:04 (ссылка)

(нет голосов)

Загрузка ...

Творец

Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 36
Всего: 329

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

Код


procedure TfmMain.FormCreate(Sender: TObject);
begin
//отлавливаем утечки памяти
  ReportMemoryLeaksOnShutdown := DebugHook <> 0;
end;

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Общие вопросы \| Следующая тема »