Новости Win API VCL Прочее Железо
  1. Как прочитать русский текст MS-DOS ?
  2. Как  запустить внешний процесс и подождать, пока он отработает?
  3. Как сохранить содержимое экрана в файл?
  4. Как получить короткий путь файла если есть длинный?
       ("c:\Program Files" ==> "c:\progra~1")
  5. Как добавить в исполняемый файл wav-файл, и затем проиграть этот звук?
  6. Как подключнить и отключить сетевые   диски ?
  7. Как скопировать картинку в буфер обмена ?
  8. Как выяснить запущен ли Delphi / C++ Builder?
  9. Как запустить аплет Панели управления?
  10. Как создать иконку из bitmap'а?
  11. Как преобразовать RGB-цвет в оттенки серого?
  12. Как отсчитать интервал времени без TTimer ?
  13. Как создать bitmap из пиктогрммы (icon)?
  14. Как вывести текст под углом ?
  15. Как вычислить разницу времени в виде: дни, часы, минуты,
    секунды?
  16. Как динамически считать номер версии EXE-шника?
  17. Как зарегистрировать расширение файла за своим приложением и контекстное меню, связанное с этим типом?
  18. Как заставить иконку минимизированого приложения мигать на таскбаре?
  19. Как лучше всего сравнить две строки без учета регистра, но с учетом текущего языка системы ?
  20. Как можно увеличить дату на произвольное число месяцев?
  21. Как подсчитать занимаемое директорией место?
  22. Как сделать бегущую стpоку?
  23. Как скопировать все файлы вместе с подкаталогами?
  24. Можно ли скопировать ( удалить,переместить,переименовать) группу файлов, используя стандартный диалог с анимацией Копирование Файлов?
  25. Перетаскивание файла(например из проводника) на форму.
  26. Как получить активный URL из браузера?
  27. Как проверить существование определённого адреса(URL) ?


Как прочитать русский текст MS-DOS ?

Для  перекодировки из Win(1251) кодовой страницы в Dos(866) кодовую страницу и обратно используются функции:

CharToOEM/OEMToChar и CharToOEMBuff/OEMToCharBuff и OemToAnsi/AnsiToOem :

Пример чтения текста дос из файла в memo
----------
procedure TForm1.FormCreate(Sender: TObject);
var
  N: PChar;
begin
  memo1.Lines.LoadFromFile('c:\11.txt');
  N := Memo1.Lines.GetText;
  OemToAnsi(N, N);
   Memo1.Lines.Text := StrPas(N);
end;

или

Пример чтения текста из файла в memo
----------
procedure TForm1.FormCreate(Sender: TObject);
var
   i,j: integer;
   s:string;
   c:set of char;
begin
  c:=['А'..'Я','а'..'я'];
  memo1.Lines.LoadFromFile('c:\11.txt');
  for i:=0 to memo1.Lines.Count do
      begin
          s:=memo1.Lines.Strings[i];
          for j:=1 to length(s) do     if chr(ord(S[j])+64) in c then s[j]:=chr(ord(S[j])+64);
          memo1.Lines.Strings[i]:=s;
      end;
end;

- назад -

Как   запустить внешний процесс и подождать, пока он отработает?
procedure TForm1.Button1Click(Sender: TObject);
var
  si:TStartupInfo;
  pi:TProcessInformation;
  cmdline:string;
begin
  ZeroMemory(@si,sizeof(si));
  si.cb:=SizeOf(si);
  cmdline:='c:\command.com';
   if not CreateProcess( nil, // No module name (use command line).
                                    PChar(cmdline), // Command line.
                                     nil, // Process handle not inheritable.
                                     nil, // Thread handle not inheritable.
                                     False, // Set handle inheritance to FALSE.
                                     0, // No creation flags.
                                     nil, // Use parent's environment block.
                                     nil, // Use parent's starting directory.
                                     si, // Pointer to STARTUPINFO structure.
                                     pi ) // Pointer to PROCESS_INFORMATION structure.
            then
               begin
                  ShowMessage( 'CreateProcess failed.' );
                  Exit;
            end;
  WaitForSingleObject( pi.hProcess, INFINITE );
  CloseHandle( pi.hProcess );
  CloseHandle( pi.hThread );
  ShowMessage('Done !');
end;

- назад -

Как сохранить содержимое экрана в файл?
procedure TForm1.Button1Click(Sender: TObject);
var
  DC: HDC;
  Canva: TCanvas;
  B: TBitmap;
begin
  Canva := TCanvas.Create;
  B := TBitmap.Create;
  DC := GetDC(0);
  try
   Canva.Handle := DC;
    with Screen do
        begin
          B.Width := Width;
          B.Height := Height;
          B.Canvas.CopyRect(Rect(0, 0, Width, Height), Canva,Rect(0, 0, Width, Height));
          B.SaveToFile('c:\screen.bmp');
        end
  finally
  ReleaseDC(0, DC);
  B.Free;
  Canva.Free
  end
end;

- назад -

Как получить короткий путь файла если есть длинный?

// короткий
GetShortPathName(LongPath)
// наоборот длинный
GetFullPathName(ShortPath)

- назад -

Как добавить в исполняемый файл wav-файл, и затем проиграть этот звук?

// В файл MyWave.rc пишешь:
// MyWave RCDATA LOADONCALL MyWave.wav
// Затем компилируешь
// brcc32.exe MyWave.rc, получаешь MyWave.res.
// В своей программе пишешь:
// {$R MyWave.res}
// или используешь программу для работы с ресурсами
// ( н-р Borland Resource WorkShop) для получения res файла

procedure RetrieveMyWave;
var
  hResource: THandle;
  pData: Pointer;
begin
    hResource:=LoadResource( hInstance, FindResource(hInstance, 'MyWave', RT_RCDATA));
  try
     pData := LockResource(hResource);
     if pData = nil then
                raise Exception.Create('Cannot read MyWave');

    // Здесь pData указывает на MyWave
    // Теперь можно, например, проиграть его (Win32):
    PlaySound('MyWave', 0, SND_MEMORY);

  finally
       FreeResource(hResource);
  end;
end;

- назад -

 

Как подключнить и отключить сетевые    диски ?

Для работы с   сетевыми    дисководами (и ресурсами типа LPT порта)
в WIN API 16 и WIN API 32 следующие функции:

1.Подключить   сетевой   ресурс

WNetAddConnection(NetResourse,Password,LocalName:PChar):longint;
где
NetResourse - имя   сетевого    ресурса (например '\\P166\c')
Password - пароль на доступ к ресурсу (если нет пароля, то пустая строка)
LocalName - имя, под которым   сетевой   ресурс будет отображен на данном компьютере (например 'F:')

Пример подключения   сетевого     диска: WNetAddConnection('\\P166\C','','F:');

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


NO_ERROR - Нет ошибок - успешное завершение
ERROR_ACCESS_DENIED - Ошибка доступа
ERROR_ALREADY_ASSIGNED - Уже подключен. Наиболее часто возникает
                                                       при повторном вызове данной функции с
                                                         теми-же параметрами.
ERROR_BAD_DEV_TYPE - Неверный тип устройства.
ERROR_BAD_DEVICE - Неверное устройство указано в LocalName
ERROR_BAD_NET_NAME - Неверный сетевой путь или сетевое имя
ERROR_EXTENDED_ERROR - Некоторая ошибка сети (см. функцию
                                                     WNetGetLastError для подробностей)
ERROR_INVALID_PASSWORD - Неверный пароль
ERROR_NO_NETWORK - Нет сети

2.Отключить   сетевой   ресурс

WNetCancelConnection(LocalName:PChar;ForseMode:Boolean):Longint;
где
LocalName - имя, под которым   сетевой   ресурс был подключен к данному
                       компьютеру (например 'F:')
ForseMode - режим отключения : False - корректное отключение. Если
                     отключаемый ресурс еще используется, то отключения не
                      произойдет (например, на   сетевом      диске    открыт файл)
                      True - скоростное некорректное отключение. Если ресурс
                      используется, отключение все равно произойдет и может
                      привести к любым последствиям (от отсутствия ошибок до
                       глухого повисания)

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

NO_ERROR - Нет ошибок - успешное завершение
ERROR_DEVICE_IN_USE - Ресурс используется
ERROR_EXTENDED_ERROR - Некоторая ошибка сети (см. функцию
                                                    WNetGetLastError для подробностей)
ERROR_NOT_CONNECTED - Указанное ус-во не является   сетевым 
ERROR_OPEN_FILES - На отключаемом   сетевом      диске   имеются
                                         открытые файлы и параметр ForseMode=false

Рекомендация: при отключении следует сначала попробовать отключить ус-во с параметром ForseMode=false и при ошибке типа ERROR_OPEN_FILES выдать запрос с сообщением о том, что ус-во еще используется и предложением отключить принудительно, и при согласии пользователя повторить вызов с ForseMode=true.

(Взято с http://delphinium.narod.ru/tips/tips/tips.html)

- назад -

Как скопировать картинку в буфер обмена ?
Clipboard.Assign(Image1.Picture);

- назад -

Как выяснить запущен ли Delphi / C++ Builder?

// Используйте функцию FindWindow.
// (Класс главного окна Delphi / C++ Builder - TAppBuilder)
// прим: обходится путём создания ложного невидемого окна
// с этим именем

if FindWindow('TAppBuilder', Nil) <> 0 Then
            ShowMessage('Delphi and or C++ Builder is running');

- назад -

Как запустить аплет Панели управления?

// Запустить аплет Панели управления можно вызвав функцию
// WinExec, для выполнения файла control.exe, которому передано
//  имя аплета. Обычно аплеты панели управления расположены в
//  каталоге System Windows и имеют расширение .cpl.

procedure TForm1.Button1Click(Sender: TObject);
begin
   WinExec('C:\WINDOWS\CONTROL.EXE TIMEDATE.CPL',
                sw_ShowNormal);
    WinExec('C:\WINDOWS\CONTROL.EXE MOUSE',
                sw_ShowNormal);
    WinExec('C:\WINDOWS\CONTROL.EXE PRINTERS',
               sw_ShowNormal);
end;

- назад -

Как создать иконку из bitmap'а?

// Нужно создать два bitmap'а:
// bitmap-маску ("AND" bitmap) и bitmap-картинку (XOR bitmap).
//  Потом передать дескрипторы "AND" и "XOR"
// bitmap-ов API функции CreateIconIndirect()

procedure TForm1.Button1Click(Sender: TObject);
  var
    IconSizeX : integer;
    IconSizeY : integer;
    AndMask : TBitmap;
    XOrMask : TBitmap;
    IconInfo : TIconInfo;
     Icon : TIcon;
begin
  {Get the icon size}
  IconSizeX := GetSystemMetrics(SM_CXICON);
  IconSizeY := GetSystemMetrics(SM_CYICON);
  {Create the "And" mask}
   AndMask := TBitmap.Create;
   AndMask.Monochrome := true;
   AndMask.Width := IconSizeX;
   AndMask.Height := IconSizeY;
   {Draw on the "And" mask}
    AndMask.Canvas.Brush.Color := clWhite;
    AndMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY));
    AndMask.Canvas.Brush.Color := clBlack;
    AndMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4);
    {Draw as a test}
    Form1.Canvas.Draw(IconSizeX * 2, IconSizeY, AndMask);
    {Create the "XOr" mask}
     XOrMask := TBitmap.Create;
     XOrMask.Width := IconSizeX;
     XOrMask.Height := IconSizeY;
     {Draw on the "XOr" mask}
     XOrMask.Canvas.Brush.Color := ClBlack;
     XOrMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY));
     XOrMask.Canvas.Pen.Color := clRed;
     XOrMask.Canvas.Brush.Color := clRed;
     XOrMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4);
     {Draw as a test}
     Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask);
     {Create a icon}
      Icon := TIcon.Create;
      IconInfo.fIcon := true;
      IconInfo.xHotspot := 0;
      IconInfo.yHotspot := 0;
       IconInfo.hbmMask := AndMask.Handle;
       IconInfo.hbmColor := XOrMask.Handle;
       Icon.Handle := CreateIconIndirect(IconInfo);
       {Destroy the temporary bitmaps}
        AndMask.Free;
        XOrMask.Free;
        {Draw as a test}
        Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon);
        {Assign the application icon}
       Application.Icon := Icon;
        {Force a repaint}
        InvalidateRect(Application.Handle, nil, true);
       {Free the icon}
        Icon.Free;
end;

- назад -

Как преобразовать RGB-цвет в оттенки серого?

function RgbToGray(RGBColor : TColor) : TColor;
var
   Gray : byte;
begin
   Gray := Round((0.30 * GetRValue(RGBColor)) +
                        (0.59 * GetGValue(RGBColor)) +
                        (0.11 * GetBValue(RGBColor )));
  Result := RGB(Gray, Gray, Gray);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
    Shape1.Brush.Color := RGB(255, 64, 64);
    Shape2.Brush.Color := RgbToGray(Shape1.Brush.Color);
end;

- назад -

Как отсчитать интервал времени без TTimer ?
procedure Delay(ms : longint);
var
    TheTime : LongInt;
begin
TheTime := GetTickCount + ms;
while GetTickCount < TheTime do
             begin
                  .....
                 {полезный код если надо что-то делать}
                  .....
               Application.ProcessMessages;
            end;
end;

- назад -

Как создать bitmap из пиктогрммы (icon)?

// Используя Bitmap.Canvas.Draw нарисуйте пиктограмму на Bitmap'е

procedure TForm1.Button1Click(Sender: TObject);
var
TheIcon : TIcon;
TheBitmap : TBitmap;
begin
TheIcon := TIcon.Create;
TheIcon.LoadFromFile('C:\Program Files\Borland\IcoCur32\EARTH.ICO');
TheBitmap := TBitmap.Create;
TheBitmap.Height := TheIcon.Height;
TheBitmap.Width := TheIcon.Width;
TheBitmap.Canvas.Draw(0, 0, TheIcon);
Form1.Canvas.Draw(10, 10, TheBitmap);
TheBitmap.Free;
TheIcon.Free;
end;

- назад -

Как вывести текст под углом ?
// Вращение текста осуществляется функцией SetWorldTransform
// перед использованием этой функции заполняется структура XForm
// Пример:

var Dc: HDc;
X: TXForm;
s: String;
{получение контекста устройства и другие подготовительные операции}
...
{заполнение структуры XForm}
X.eM11 := cos(45 * 2 * pi / 360);
X.eM22 := cos(45 * 2 * pi / 360);
X.eM21 := sin(45 * 2 * pi / 360);
X.eM12 := -sin(45 * 2 * pi / 360);

SetWorldTransform(Dc,@X);
s := 'Текст под наклоном 45 градусов';
TextOut(Dc,50,0,s,Length(s));

// автор - Valler

- назад -

Как вычислить разницу времени в виде: дни, часы, минуты, секунды?
// Целая часть = дни, дробная = часы, минуты, секунды и
// миллисекунды (см. пример, параметры - две переменные TDateTime)

var
ddays : Integer;
dtime : TTime;
begin
..
if t2 > t1 then
  begin
     ddays := Trunc(t2 - t1);
     dtime := Frac(t2 - t1);
end;
...
end;

// автор - InSAn

- назад -

Как динамически считать номер версии EXE-шника?
// Очень просто: версия - это особый тип ресурса, следовательно, его можно
// прочитать как ресурс и разбираться с ним. Второй путь - API, функции
// GetFileVersionInfo, GetFileVersionInfoSize позволяют читать
// структуру с информацией о версии для указанного EXE файла
// (не обязательно своего).

// Получение информации о версии программы...
procedure GetBuildInfo(var V1, V2, V3, V4: Word);
var
VerInfoSize: DWORD;
VerInfo: Pointer;
VerValueSize: DWORD;
VerValue: PVSFixedFileInfo;
Dummy: DWORD;
begin
  VerInfoSize := GetFileVersionInfoSize(PChar(ParamStr(0)), Dummy);
  if VerInfoSize = 0 then begin
      Dummy := GetLastError;
      ShowMessage(IntToStr(Dummy));
     end; {if}
  GetMem(VerInfo, VerInfoSize);
  GetFileVersionInfo(PChar(ParamStr(0)), 0, VerInfoSize, VerInfo);
  VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
  with VerValue^ do begin
     V1 := dwFileVersionMS shr 16;
     V2 := dwFileVersionMS and $FFFF;
     V3 := dwFileVersionLS shr 16;
    V4 := dwFileVersionLS and $FFFF;
  end;
  FreeMem(VerInfo, VerInfoSize);
end;

// Автор: Full

- назад -

Как зарегистрировать расширение файла за своим приложением и контекстное меню, связанное с этим типом?
// Пример регистрирует расширение файла(.myext) - файлы этого
// типа будут открываться приложением MyApp.Exe.
// Также регестрируется одно действие (action)
// по умолчанию для файлов этого типа и два дополнительных
// пункта контекстного меню, связанного сэтим типом файлов.
// Возможно, потребуется перезайти в систему чтобы
// изменения вступили в силу.

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
R : TRegIniFile;
begin
R := TRegIniFile.Create('');
with R do begin
RootKey := HKEY_CLASSES_ROOT;
WriteString('.myext','','MyExt');
WriteString('MyExt','','Some description of MyExt files');
WriteString('MyExt\DefaultIcon','','C:\MyApp.Exe,0');
WriteString('MyExt\Shell','','This_Is_Our_Default_Action');
WriteString('MyExt\Shell\First_Action','','This is our first action');
WriteString('MyExt\Shell\First_Action\command','','C:\MyApp.Exe /LotsOfParamaters %1');
WriteString('MyExt\Shell\This_Is_Our_Default_Action','','This is our default action');
WriteString('MyExt\Shell\This_Is_Our_Default_Action\command','','C:\MyApp.Exe %1');
WriteString('MyExt\Shell\Second_Action','','This is our second action');
WriteString('MyExt\Shell\Second_Action\command','','C:\MyApp.Exe /TonsOfParameters %1');
Free;
end;
end;

// Автор: InSAn

- назад -

Как заставить иконку минимизированого приложения мигать на таскбаре?
procedure TForm1.Timer1Timer(Sender: TObject);
begin
   FlashWindow(Application.Handle, True);
end;

- назад -

Как лучше всего сравнить две строки без учета регистра, но с учетом текущего языка системы ?

function AnsiCompareText(const S1, S2: string): Integer;

- назад -

Как можно увеличить дату на произвольное число месяцев?
// На форме три MaskEdit'а (текущая дата, на сколько добавить, конечный результат)

uses sysutils;

procedure TForm1.FormCreate(Sender: TObject);
begin
MaskEdit1.Text:=DateToStr(now);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  IncDate(
  Copy(MaskEdit2.Text, 7, 2),
  Copy(MaskEdit2.Text, 4, 2),
  Copy(MaskEdit2.Text, 1, 2));
end;

procedure TForm1.IncDate(UpYear, UpMonth, UpDay: string);
var UpYear1, UpMonth1, UpDay1: word;
datein, dateout: TDate;
begin
  DateIn:=StrToDate(MaskEdit1.Text);
  DateOut:=IncMonth(DateIn, StrToInt(UpMonth));
  //                ^^^ эта функция увеличивает месяцы (SysUtils.pas)
  DateOut:=DateOut+StrToInt(UpDay);
  DecodeDate(DateOut, UpYear1, UpMonth1, UpDay1);
  DateOut:=EncodeDate(StrToInt(UpYear)+UpYear1, UpMonth1, UpDay1);
  MaskEdit3.Text:=DateToStr(DateOut);
end;

- назад -

Как подсчитать занимаемое директорией место?
var
  DirBytes : integer;

function DirSize(Dir:string):integer;
var
  SearchRec : TSearchRec;
  Separator : string;
begin
  if Copy(Dir,Length(Dir),1)='\' then Separator := ''
      else Separator := '\';
  if FindFirst(Dir+Separator+'*.*',faAnyFile,SearchRec) = 0 then begin
       if FileExists(Dir+Separator+SearchRec.Name) then begin
         DirBytes := DirBytes + SearchRec.Size;
        {Memo1.Lines.Add(Dir+Separator+SearchRec.Name);}
       end
      else
     if DirectoryExists(Dir+Separator+SearchRec.Name) then begin
          if (SearchRec.Name<>'.') and (SearchRec.Name<>'..') then
             DirSize(Dir+Separator+SearchRec.Name);
    end;
    while FindNext(SearchRec) = 0 do begin
      if FileExists(Dir+Separator+SearchRec.Name) then begin
             DirBytes := DirBytes + SearchRec.Size;
            {Memo1.Lines.Add(Dir+Separator+SearchRec.Name);}
      end
      else
      if DirectoryExists(Dir+Separator+SearchRec.Name) then begin
           if (SearchRec.Name<>'.') and (SearchRec.Name<>'..') then begin
             DirSize(Dir+Separator+SearchRec.Name);
          end;
     end;
  end;
end;
FindClose(SearchRec);
end;

- назад -

Как сделать бегущую стpоку?
// с помощью TLabel и TTimer.
// Пример:

procedure TForm1.Timer1Timer(Sender: TObject);
const
   LengthGoString = 10;
   GoString = 'В конце стpоку желательно повтоpить,'+
    ' чтоб получить эффект кольцевого движения! В конце ст';
    i: Integer = 1;
begin
  Label1.Caption:=Copy(GoString,i,LengthGoString);
  Inc(i);
  If Length(GoString)-LengthGoString < i then i:=1;
end;

- назад -

Как скопировать все файлы вместе с подкаталогами?
uses ShellApi;

procedure TForm1.Button1Click(Sender: TObject);
var
   OpStruc: TSHFileOpStruct;
   frombuf, tobuf: Array [0..128] of Char;
begin
  FillChar( frombuf, Sizeof(frombuf), 0 );
  FillChar( tobuf, Sizeof(tobuf), 0 );
  StrPCopy( frombuf, 'h:\hook\*.*' );
  StrPCopy( tobuf, 'd:\temp\brief' );
  With OpStruc DO
    begin
      Wnd:= Handle;
       wFunc:= FO_COPY;
       pFrom:= @frombuf;
       pTo:=@tobuf;
       fFlags:= FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;
       fAnyOperationsAborted:= False;
       hNameMappings:= Nil;
       lpszProgressTitle:= Nil;
  end;
ShFileOperation( OpStruc );
end;

- назад -

Можно ли скопировать группу файлов, используя стандартный диалог
с анимацией Копирование Файлов?
// В следующем примере используется функция SHFileOperation для
// копирования группы файлов и показа анимированного диалога. Вы можете
// использовать также следующие флаги для копирования, удаления,
// переноса и переименования файлов.
// TO_COPY, FO_DELETE, FO_MOVE, FO_RENAME
// Примечание: буфер, содержащий имена файлов для
// копирования должен заканчиваться двумя нулевыми символами.
// Пример:

uses ShellAPI;

procedure TForm1.Button1Click(Sender: TObject);
var
  Fo : TSHFileOpStruct;
  buffer : array[0..4096] of char;
  p : pchar;
begin
  FillChar(Buffer, sizeof(Buffer), #0);
  p := @buffer;
  p := StrECopy(p, 'C:\DownLoad\1.ZIP') + 1;
  p := StrECopy(p, 'C:\DownLoad\2.ZIP') + 1;
  p := StrECopy(p, 'C:\DownLoad\3.ZIP') + 1;
  StrECopy(p, 'C:\DownLoad\4.ZIP');
  FillChar(Fo, sizeof(Fo), #0);
  Fo.Wnd := Handle;
  Fo.wFunc := FO_COPY;
  Fo.pFrom := @Buffer;
  Fo.pTo := 'D:\';
  Fo.fFlags := 0;
  if ((SHFileOperation(Fo) <> 0) or
    (Fo.fAnyOperationsAborted <> false)) then
         ShowMessage('Cancelled')
end;

- назад -

Перетаскивание файла(например из проводника) на форму.
{ На эту форму можно бросить файл (например из проводника)
и он будет открыт }

unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics,
    Controls, Forms, Dialogs,StdCtrls,
      ShellAPI {обязательно!};
type
   TForm1 = class(TForm)
       Memo1: TMemo;
       FileNameLabel: TLabel;
      procedure FormCreate(Sender: TObject);
      procedure FormDestroy(Sender: TObject);
    protected
  {Это и есть самая главная процедура}
    procedure WMDropFiles(var Msg: TMessage); message wm_DropFiles;
   end;

var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMDropFiles(var Msg: TMessage);
var
Filename: array[0 .. 256] of Char;
Count : integer;
begin
 { Получаем количество файлов (просто пример) }
  nCount := DragQueryFile( msg.WParam, $FFFFFFFF,
  acFileName, cnMaxFileNameLen);
{ Получаем имя первого файла }
  DragQueryFile( THandle(Msg.WParam),
          0, { это номер файла }
         Filename,SizeOf(Filename) ) ;
{ Открываем его }
    with FileNameLabel do begin
       Caption := LowerCase(StrPas(FileName));
       Memo1.Lines.LoadfromFile(Caption);
   end;
{ Отдаем сообщение о завершении процесса }
 DragFinish(THandle(Msg.WParam));
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 { Говорим Windows, что на нас можно бросать файлы }
 DragAcceptFiles(Handle, True);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 { Закрываем за собой }
 DragAcceptFiles(Handle, False);
end;

end.

- назад -

Как получить активный URL из браузера?
{Автор: Ruslan Abu Zant
Приводимая здесь функция показывает, как Ваше приложение может извлечь из браузера (IE или Netscape) URL , как, например, это делает аська.
Cовместимость: Delphi 4.x (или выше)
Не забудьте добавить DDEMan в Ваш проект!}

uses windows, ddeman, ......

function Get_URL(Servicio: string): String;
var
   Cliente_DDE: TDDEClientConv;
   temp:PChar;      //<<-------------------------This is new
begin
    Result := '';
    Cliente_DDE:= TDDEClientConv.Create( nil );
     with Cliente_DDE do
        begin
           SetLink( Servicio,'WWW_GetWindowInfo');
           temp := RequestData('0xFFFFFFFF');
           Result := StrPas(temp);
           StrDispose(temp);  //<<-Предотвращаем утечку памяти
           CloseLink;
        end;
      Cliente_DDE.Free;
end;

procedure TForm1.Button1Click(Sender);
begin
   showmessage(Get_URL('Netscape'));
      // или
   showmessage(Get_URL('IExplore'));
end;

- назад -

Как проверить существование определённого адреса(URL) ?
{Данная функция позволяет Вам проверить существование определённого адреса(URL) в интернете. Естественно она может пригодиться веб-мастерам, у которых на сайте много ссылок, и необходимо с определённой периодичнойстью эти ссылки проверять.

URL может быть как с префиксом http:/ так и без него - эта функция добавляет префикс http:// если он отсутствует (необходимо для функции internetOpenUrl которая так же поддерживает FTP:// и gopher://

Эта функция проверяет только два возвращаемых кода '200'(ОК) или '302' (Редирект), но Вы можете заставить проверять функцию и другие коды. Для этого достаточно модифицировать строчку "result := ".

Платформа: Delphi 3.x (или выше) }

uses wininet;

Function CheckUrl(url:string):boolean;
var
hSession, hfile, hRequest: hInternet;
dwindex,dwcodelen :dword;
dwcode:array[1..20] of char;
res : pchar;
begin
  if pos('http://',lowercase(url))=0 then
     url := 'http://'+url;
  Result := false;
  hSession := InternetOpen('InetURL:/1.0',
       INTERNET_OPEN_TYPE_PRECONFIG,nil, nil, 0);
  if assigned(hsession) then
    begin
      hfile := InternetOpenUrl(
           hsession,
           pchar(url),
           nil,
           0,
           INTERNET_FLAG_RELOAD,
           0);
      dwIndex  := 0;
      dwCodeLen := 10;
      HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE,
              @dwcode, dwcodeLen, dwIndex);
      res := pchar(@dwcode);
      result:= (res ='200') or (res ='302');
      if assigned(hfile) then
        InternetCloseHandle(hfile);
      InternetCloseHandle(hsession);
    end;
  
end;

- назад -