Назад к содержанию

  var  Windir  : String;
         WindirP : PChar;
  
                       .  .  .  .  .
         WinDirP := StrAlloc(MAX_PATH);
  
         Res := GetWindowsDirectory(WinDirP, MAX_PATH);
  
         if Res > 0 then WinDir := StrPas(WinDirP);
  
                     .  .  .  .  .

Назад к содержанию

Назад к содержанию

Назад к содержанию

Назад к содержанию

  Пример формы, использующей анимированный курсор:
      ........................................................
      procedure TForm1.Button1Click(Sender: TObject);
      var
        h : THandle;
      begin
        h := LoadImage(0,'C:\TheWall\Magic.ani',
          IMAGE_CURSOR, 0, 0,
          LR_DEFAULTSIZE or LR_LOADFROMFILE);
        if h = 0 then ShowMessage('Cursor not loaded')
        else
        begin
          Screen.Cursors[1] := h;
          Form1.Cursor := 1;
        end;
      end;
    ... ..... ...... ....... ....... ...... ..

    Можно, используя RxLib. После его установки в меню View появится пунктик Project Resources. Hужно выбрать Project Resources->New->User Data и добавить нужный файл. В данном случае ресурс был назван "RCDATA_1".
Если RxLib нет, то нужно создать файл описания ресурсов:

=== Begin gifs.rc ===
  mygif rcdata "имя_gif-файла.gif"
  mygif1 rcdata "RCDATA_1"
=== End dots.rc ===

var
    rs     : TResourceStream;
    a      : Pointer;
  begin
    rs:=TResourceStream.Create(hinstance,'RCDATA_1',RT_RCDATA);
    try
      GetMem(a,rs.size);
      rs.Read(a^,rs.size);  {Теперь a - динамический указатель на код}
  
      { Здесь делается все, что необходимо с кодом, используя указатель a }
  
      FreeMem(a);
    finally
      rs.Free;
    end;
  end;
  
  А можно и так, если необходимо записать ресурс в файл:
  var
    rs     : TResourceStream;
    fs     : TFileStream;
  begin
     rs:=TResourceStream.Create(hInstance, 'mygif', RT_RCDATA);
     fs:=TFileStream.Create('имя_gif-файла.gif', fmCreate);
     try
       fs.CopyFrom(rs, rs.Size);
     finally
       fs.Free;
       rs.Free;
     end;
end;

  ........................................................
    uses ShlObj, ComObj, ActiveX;
  
    procedure CreateLink(const PathObj, PathLink, Desc, Param: string);
    var
      IObject: IUnknown;
      SLink: IShellLink;
      PFile: IPersistFile;
    begin
      IObject := CreateComObject(CLSID_ShellLink);
      SLink := IObject as IShellLink;
      PFile := IObject as IPersistFile;
      with SLink do begin
        SetArguments(PChar(Param));
        SetDescription(PChar(Desc));
        SetPath(PChar(PathObj));
      end;
      PFile.Save(PWChar(WideString(PathLink)), FALSE);
    end;
  ........................................................

Назад к содержанию

type

TForm1 = class(TForm)

{ ... }

private

{ эта процедура будет вызываться при нажатии на кнопку }

procedure ButtonClicked(Sender : TObject);

public

{ в этой процедуре происходит создание кнопки }

procedure CreateButton;

end;

{ ... }

procedure TForm1.CreateButton;

var

Btn : TButton;

begin

Btn := TButton.Create(Self); { Уничтожать кнопку будет форма }

Btn.Parent := Self; { Родителем кнопки будет форма }

Btn.OnClick := ButtonClicked; { Процедура, которая будет исполняться при }

Btn.Visible := true; { нажатии на кнопку }

end;

Назад к содержанию

---

Как в TTreeView построить дерево открытых окон? Alex Shakhajlo 1
Alex.Shakhajlo@f701.n461.z2.fidonet.org

Мне стало интересно построить дерево окон и вот что у меня получилось:

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, HistEdit, Buttons, StdCtrls, ColoredGrid, TLHelp32, ComCtrls;

type

TForm1 = class(TForm)

List : TTreeView;

procedure FormCreate(Sender : TObject);

private

{ Private declarations }

procedure listlevel(N : TTreeNode; H : HWND);

public

{ Public declarations }

end;

var

Form1 : TForm1;

implementation

{$R *.DFM}

procedure TForm1.ListLevel;

var

B : array[0..128] of char;

S : String;

T : TTreeNode;

C, W : HWND;

begin

W := H;

while W <> 0 do

begin

GetClassName (W, @B, 128);

S := StrPas(B);

GetWindowText(W, @B, 128);

S := S + '(' + StrPas(B) + ')';

T := List.Items.AddChild(N, S);

C := GetWindow(W, GW_CHILD);

ListLevel(T, C);

W := GetNextWindow(W, GW_HWNDNEXT);

end;

end;

procedure TForm1.FormCreate(Sender : TObject);

var

H : HWnd;

begin

H := GetDeskTopWindow;

ListLevel(nil, H);

end;

end.

Назад к содержанию

---

     Как использовать Clipboard для переноса данных в собственном формате?
Не только возможно, именно так поступают функции Clipboard.GetComponent и Clipboard.SetComponent.

Сперва Вы должны зарегистрировать свой собственный формат данных для Clipboard с помощью функции RegisterClipboardFormat():

CF_MYFORMAT := RegisterClipboardFormat('My Format Description');
Далее вы должны выполнить эти шаги : 1. Создать поток (memory stream) и записать туда данные.
2. Создать глобальный буфер в памяти и скопировать поток туда.
3. Вызвать Clipboard.SetAsHandle(), чтобы поместить буфер в clipboard.
Пример:

var

HBuf : THandle;

BufPtr : Pointer;

MStream : TMemoryStream;

begin

MStream := TMemoryStream.Create;

try

{-- Write your data to the stream. --}

HBuf := GlobalAlloc(GMEM_MOVEABLE, MStream.Size);

try

BufPtr := GlobalLock(HBuf);

try

Move(MStream.Memory^, BufPtr^, MStream.Size);

Clipboard.SetAsHandle(CF_MYFORMAT, HBuf);

finally

GlobalUnlock(HBuf);

end;

except

GlobalFree(HBuf);

raise;

end;

finally

MStream.Free;

end;

end;

ВНИМАНИЕ: Не уничтожайте буфер, созданный с GlobalAlloc(). Поскольку Вы поместили его в Clipboard, это уже дело Clipboard'а его уничтожить. Опять же, получая буфер из Clipboard, не уничтожайте этот буфер - просто сделайте копию содержимого.

Для обратного получения потока и данных, сделайте что-нибудь вроде этого:

var

HBuf : THandle;

BufPtr : Pointer;

MStream : TMemoryStream;

begin

HBuf := Clipboard.GetAsHandle(CF_MYFORMAT);

if HBuf <> 0 then

begin

BufPtr := GlobalLock(HBuf);

if BufPtr <> nil then

begin

try

MStream := TMemoryStream.Create;

try

MStream.WriteBuffer(BufPtr^, GlobalSize(HBuf));

MStream.Position := 0;

{-- Read your data from the stream. --}

finally

MStream.Free;

end;

finally

GlobalUnlock(HBuf);

end;

end;

end;

end;

Назад к содержанию

---

Как перевести визуальный компонент, такой, как TPanel, в состояние перемещения (взять и перенести)? Borland TI N2909 (перевод: Акжан Абдулин)
 

Пример:

{ В случае Panel1 : TPanel - обработчик события OnMouseDown }

procedure TForm1.Panel1MouseDown(Sender : TObject; Button : TMouseButton;

Shift : TShiftState; X, Y : Integer);

const

SC_DRAGMOVE = $F012; { a magic number }

begin

ReleaseCapture;

P.Perform(WM_SYSCOMMAND, SC_DRAGMOVE, 0);

end;

Назад к содержанию

---

     Как изменить внешний вид хинтов (всплывающих подсказок)? Dmitry Medved
 

1. Создаем свой класс - потомок от THintWindow

type

TCustomHint = class(THintWindow)

public

constructor Create(AOwner: TComponent); override;

end;

Пpимечание

Этот способ не позволит изменить цвет шpифта - для этого пpидется пеpекpывать метод Paint;

Если пеpекpыть CreateParams, то можно, напpимеp, наpисовать Hint в фоpме облачка.

2. Меняем фонт:

constructor TCustomHint.Create(AOwner : TComponent);

begin

inherited Create(AOwner);

with Canvas.Font do // Именно так, а не пpосто Font!

begin

Name := 'Times New Roman Cyr';

Style := [fsBold, fsItalic];

Size := 40;

end;

end;

3. Устанавливаем новый хинт

procedure TForm1.FormCreate(Sender : TObject); // Это может быть любой обpаботчик

begin

HintWindowClass := TMyHint; // Устанавливаем глобальную пеpеменную

Application.ShowHint := False; // Application.FHintWindow.Free

Application.ShowHint := True; // Application.FHintWindow.Create

end;

Назад к содержанию

---

Переключение языка из программы
Для переключения языка применяется вызов LoadKeyboardLayout:

var russian, latin: HKL; 
     russian:=LoadKeyboardLayout('00000419', 0);
     latin:=LoadKeyboardLayout('00000409', 0);
    
    -- -- -- -- -- где то в  программе --- --- --- 
   SetActiveKeyboardLayout(russian);

Наверх

---

Отключение CTRL-ALT-DEL
при помощи SystemParametersInfo
Бывают ситуации, когда вашей программе понадобится отключить реакцию на клавиши
Ctrl-Alt-Del (например, если вы не хотите, чтобы ее выгрузили из памяти). Это
можно сделать при помощи функции API SystemParametersInfo, которая позволяет
узнать, либо установить параметры операционной системы, такие как установки
клавиатуры, дисплея, звука и т.д. Она используется в Панели Управления. Синтакс
функции следующий:
BOOL SystemParametersInfo(
UINT uiAction,  // параметр, который нужно узнать или установить
UINT uiParam,   // зависит от действия
PVOID pvParam,  // зависит от действия
UINT fWinIni    // флаг обновления информации о пользователе (user profile));
Значение каждого параметра объясняется в Win32 Developer's Reference. Теперь,
чтобы сделать то, что мы хотим, вызываем следующую прцедуру:
procedure DisableCtrlAltDel;
 var
 i : integer;
begin
 i := 0;
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, @i, 0);
end.
Аналогично можно отключить Alt-Tab. Для этого нужно задать SPI_SETFASTTASKSWITCH
в качестве первого параметра функции.

Назад у оглавлению

---

Как проверить диск на наличие *.dbf в директории программы и соответствия полей?

Ivanuts V.A. (ivanuts@altavista.net) 31.10.2001
1. Для определения наличия любого файла на диске используется стандартное выражение:

if not FileExists(FTableName) then

raise EError.Create('Таблица ' + ExtractFileName(FTableName) + ' по указанному пути отсутствует.')

2. Чтобы перед использованием DBF-таблицы проверить ее версию можно воспользоваться следующей функцией:

const

DB3 = $03; //Версия 3.х

DB4 = $04; //Версия 4.х

DB5 = $05; //Версия for Windows

DB3Memo = $83; //Версия 3.х cполями MEMO

DB4Memo = $84; //Версия 4.х cполями MEMO

function TMyMenu.GetTableVersion : Byte;

....

FFile := TFileStream.Create (FTableName, fmOpenReadWrite);

try

//Информация о заголовке таблицы

FFile.Seek(0, soFrombeginning);

FFile.ReadBuffer(FHeader, Sizeof(FHeader)); //FHeader - переменная, указывающая на структуру заголовка

Result := FHeader.VersionNumber; //Здесь VersionNumber - поле из записи FHeader

except

Raise EError.Create('Ошибка чтения заголовка таблицы.');

end;

....

Дальше зная с какой именно таблицей приходится работать, нетрудно выбрать переменую, указывающую на структуру полей таблицы и т.д.

Назад у оглавлению

---

Каким образом или какой функцией установить системную дату и время Windows 95 средствами Delphi. Ivanuts V.A. (ivanuts@altavista.net) 31.10.2001
В своих приложениях, которые требуют установки единого времени и даты на разных машинах, я использую установку системного времени и даты , взятых путем запроса с сервера БД. У меня это работает вот так:

procedure TGlavMenu.SetSysTime(Sender: TObject);

var

Present : TSystemTime;

Year, Month, Day, Hour, Min, Sec, MSec: Word;

begin

qrTime.Open;{ Этот квери возвращает системное время и дату с сервера БД. Здесь можно использовать и другие источники - например TEdit и т.д.}

DecodeDate(qrTimeDATE.Value, Year, Month, Day);

DecodeTime(qrTimeDATE.Value, Hour, Min, Sec, MSec);

Present.wYear := Year;

Present.wMonth := Month;

Yares := Year;

Months := Month;

Present.wDay := Day;

Present.wHour := Hour - 3;

Present.wMinute := Min;

Present.wSecond := Sec;

Present.wMilliseconds := MSec;

SetSystemTime(Present);

qrTime.Close;

end;

 

Назад у оглавлению

---

Как определить нормальное (ненормальное) завершение выполнения файла. Как закрыть пустое окно, после выполнения.

Ivanuts V.A. (ivanuts@altavista.net) 31.10.2001
Если речь идет о выполнении файла в паралельном процессе, то необходимо создать такой процесс:

var

Startup: TStartupInfo;

Process: TProcessInformation;

Status: DWORD;

szApp, szCmdLine : String;

Env: Pointer;

begin

Result := UM_ERROR;

Startup.lpReserved := PChar(0);

Startup.lpDesktop := PChar(0);

Startup.lpTitle := PChar(0);

Startup.dwFlags := STARTF_USESHOWWINDOW;

Startup.wShowWindow := SW_HIDE;{Вот здесь и необходимо выбрать способ запуска - видимое или скрытое окно.}

Startup.cbReserved2 := 0;

Startup.lpReserved2 := PByte(0);

if CreateProcess(

PChar(szApp), // lpApplicationName

PChar(szCmdLine), // lpCommandLine

PSecurityAttributes(0), // lpProcessAttributes

PSecurityAttributes(0), // lpThreadAttributes

False, // bInheritHandles

HIGH_PRIORITY_CLASS, // dwCreationFlags

Env, // lpEnvironment

PChar(0), // lpCurrentDirectory

Startup, // lpStartupInfo

Process // lpProcessInformation) then

begin

GetExitCodeProcess(Process.hProcess, Status);

while Status = STILL_ACTIVE do

begin

Sleep(10);

GetExitCodeProcess(Process.hProcess, Status);

end;

Result := Status;

end;

end;

Результат такой функции и даст ответ о завершении процесса. Подробней о функциях CreateProcess и GetExitCodeProcessможно прочесть в Help for Delphi.

Назад у оглавлению

---

Как определить работает ли уже данное приложение или это первая его копия? Alex Shakhajlo 2.11.2001 Для Delphi 1. Каждый экземпляр программы имеет ссылку на свою предыдущую копию - hPrevInst: hWnd. Ее можно проверить перед созданием приложения и при необходимости отреагировать соответствующим образом. Если запущена только одна копия, то эта ссылка равна нулю.
Пример:

procedure TForm1.FormCreate(Sender: TObject); 
    begin 
      {Проверяем есть ли указатель на предыдущую копию приложения}
      IF hPrevInst <> 0 THEN BEGIN 
        {Если есть, то выдаем сообщение и выходим}
        MessageDlg('Программа уже запущена!', mtError, [mbOk], 0); 
        Halt; 
      END; 
      {Иначе - ничего не делаем (не мешаем созданию формы)}
  end;

P.S. Для выхода необходимо использовать Halt, а не Close, как хотелось бы, так как форма еще не создана и закрывать нечего.
Есть и другой способ - по списку загруженных приложений

procedure TForm1.FormCreate(Sender: TObject);
    VAR
     Wnd : hWnd;
     buff : ARRAY[0.. 127] OF Char;
    Begin
     Wnd := GetWindow(Handle, gw_HWndFirst);
     WHILE Wnd <> 0 DO BEGIN
      IF (Wnd <> Application.Handle) AND (GetWindow(Wnd, gw_Owner) = 0)
      THEN BEGIN
       GetWindowText (Wnd, buff, sizeof (buff ));
       IF StrPas (buff) = Application.Title THEN 
       BEGIN
        MessageDlg('Приложение уже загружено', mtWarning, [mbOk], 0);
        Halt;
       END;
      END;
      Wnd := GetWindow (Wnd, gw_hWndNext);
     END;
  End;

Еще один интересный способ для Win32. Дело в том, что можно в памяти создавать временные файлы. При перезагрузке они теряются, а так существуют. Кстати, этот метод можно использовать и для обмена информацией между вашими приложениями.
Пример:

program Project1;
    uses
      Windows, // Обязательно
      Forms,
      Unit1 in 'Unit1.pas' {Form1};
    {$R *.RES}
    Const
     MemFileSize = 1024;
     MemFileName = 'one_inst_demo_memfile';
    Var
     MemHnd : HWND;
    begin
      { Попытаемся создать файл в памяти }
      MemHnd := CreateFileMapping(HWND($FFFFFFFF),
                                  nil,
                                  PAGE_READWRITE,
                                  0,
                                  MemFileSize,
                                  MemFileName);
      { Если файл не существовал запускаем приложение }
      if GetLastError<>ERROR_ALREADY_EXISTS then
      begin
       Application.Initialize;
       Application.CreateForm(TForm1, Form1);
       Application.Run;
      end;
      CloseHandle(MemHnd);
  end.

Часто при работе у пользователя может быть открыто 5-20 окон и сообщение о том, что программа уже запущено приводит к тому, что он вынужден полчаса искать ранее запущенную копию. Выход из положения - найдя копию программы активировать ее, для чего в последнем примере перед HALT необходимо добавить строку :
SetForegroundWindow(Wnd);
Например так:
program Project0;
uses
  Windows,  // !!!
  Forms,
  Unit0 in 'Unit0.pas' {Form1};
var
  Handle1 : LongInt;
  Handle2 : LongInt;
{$R *.RES}
begin
  Application.Initialize;
  Handle1 := FindWindow('TForm1',nil);
  if handle1 = 0 then
    begin
      Application.CreateForm(TForm1, Form1);
      Application.Run;
    end
  else
    begin
      Handle2 := GetWindow(Handle1,GW_OWNER);
       //Чтоб заметили :)
      ShowWindow(Handle2,SW_HIDE); ShowWindow(Handle2,SW_RESTORE);
      SetForegroundWindow(Handle1); // Активизируем
    end;
end.

Назад к содержанию

---

Запуск внешней программы и ожидание ее завершения

procedure TForm1.Button1Click(Sender: TObject);
    var
      si : Tstartupinfo;
      p  : Tprocessinformation;
    begin
     FillChar( Si, SizeOf( Si ) , 0 );
     with Si do begin
      cb := SizeOf( Si);
      dwFlags := startf_UseShowWindow;
      wShowWindow := 4;
     end;
     Application.Minimize;
     Createprocess(nil,'notepad.exe',nil,nil,false,Create_default_error_mode,nil,nil,si,p);
     Waitforsingleobject(p.hProcess,infinite);
     Application.Restore;
  end;

Наверх к содержанию

---

СGI программа должна показывать GIF изображение.

Имею тег Программа должна выдавать в браузер изображение. Прочитать JPeg, указать ContentType=Image/jpeg и выдать изображение в SaveToStream умею. Как сделать тоже самое для файлов GIF, в особенности анимационных? Если можно просто перелить дисковый файл (пусть он хоть трижды GIF) в Response CGI-програмы, то как это сделать?
 

Выдайте из скрипта следующее:

Content-type: image/gif

<содержимое gif-файла>

Наверх к содержанию

---

Как программно создать ярлык?

uses ShlObj, ComObj, ActiveX;
    
    procedure CreateLink(const PathObj, PathLink, Desc, Param: string);
    var
      IObject: IUnknown;
      SLink: IShellLink;
      PFile: IPersistFile;
    begin
      IObject := CreateComObject(CLSID_ShellLink);
      SLink := IObject as IShellLink;
      PFile := IObject as IPersistFile;
      with SLink do begin
        SetArguments(PChar(Param));
        SetDescription(PChar(Desc));
        SetPath(PChar(PathObj));
      end;
      PFile.Save(PWChar(WideString(PathLink)), FALSE);
  end;