Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
выпущен 8 мая!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Получение информации о диске

Два компьютершика спорят:
- Можно ли научить "комп" заикаться?
- Да ты что никогда!
Второй:
- Берет магнит и начинает водить возле винчестера!
В итоге получается песня Расторгуева+Леонидов: "Давай за баранку держись, давай брат шофер до конца"...


 function GetVolumeInfoFVS(const Dir:string;
 var FileSystemName,VolumeName:string;var Serial:longint):boolean;
 {Получение информации о диске
 Dir - каталог или буква требуемого диска
 FileSystemName - название файловой системы
 VolumeName - метка диска
 Serial - серийный номер диска
 В случае ошибки функция возвращает false}
 var
   root:pchar;
   res:longbool;
   VolumeNameBuffer,FileSystemNameBuffer:pchar;
   VolumeNameSize,FileSystemNameSize:DWord;
   VolumeSerialNumber,MaximumComponentLength,FileSystemFlags:DWORD;
   s:string;
   n:integer;
 begin
   n:=pos(':',Dir);
   if n> 0 then s:=copy(Dir,1,n+1) else s:=s+':';
   if s[length(s)]=':' then s:=s+'\';
   root:=pchar(s);
   getMem(VolumeNameBuffer,256);
   getMem(FileSystemNameBuffer,256);
   VolumeNameSize:=255;
   FileSystemNameSize:=255;
   res:=GetVolumeInformation(Root,VolumeNameBuffer,VolumeNameSize
   ,@VolumeSerialNumber,
   MaximumComponentLength, FileSystemFlags
   ,FileSystemNameBuffer,FileSystemNameSize);
   Result:=res;
   VolumeName:=VolumeNameBuffer;
   FileSystemName:=FileSystemNameBuffer;
   Serial:=VolumeSerialNumber;
   freeMem(VolumeNameBuffer,256);
   freeMem(FileSystemNameBuffer,256);
 end;
 




Получить список дисков


Пpиходит сантехник(С) к пpогpаммисту(П) pемонтиpовать засоpившуюся pаковину.
C. начинает ковыpяться в отстойнике...
С.- А у вас тут из сети все на винт падает...вот и забило..
П.- Hадо винт больше ставить?
С.- Hет, винт надо вообще спилить к #$%^&й матеpи.

Компонент, выводящий список дисков уже существует – TDriveComboBox, но он не всегда удобен. Я привожу пример программы, выводящей список дисков в двух разных видах.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   i, j: integer;
   buf: array [0..499] of char;
   DrvStr: array [0..9] of char;
   LogDrives: set of 0..25;
 begin
   integer(LogDrives) := GetLogicalDrives;
   for i := 0 to 25 do
     if (i in LogDrives) then
       ListBox1.Items.Add(chr(i + 65));
 
   GetLogicalDriveStrings(1000, buf);
   i := 0;
   repeat
     FillChar(DrvStr, SizeOf(DrvStr), #0);
     j := 0;
     repeat
       DrvStr[j] := buf[i];
       inc(j);
       inc(i);
     until
       (buf[i] = #0) or (j > 9);
     inc(i);
     ListBox2.Items.Add(DrvStr);
   until
     ((buf[i-1] = #0) and (buf[i] = #0)) or (i > 499);
 end;
 




Определить тип дискового накопителя


Объявление в Интернете: Куплю винчестер. Жёсткие диски не предлагать!

Нужно воспользоваться API функцией GetDriveType():


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   case GetDriveType('C:\') of
     0: ShowMessage('The drive type cannot be determined');
     1: ShowMessage('The root directory does not exist');
     DRIVE_REMOVABLE: ShowMessage('The disk can be removed');
     DRIVE_FIXED: ShowMessage('The disk cannot be removed');
     DRIVE_REMOTE: ShowMessage('The drive is remote (network) drive');
     DRIVE_CDROM: ShowMessage('The drive is a CD-ROM drive');
     DRIVE_RAMDISK: ShowMessage('The drive is a RAM disk');
   end;
 end;
 




Как из DLL узнать узнать полный путь к этой DLL


 function GetModuleFileNameStr(Instance: THandle): string;
 var
   buffer: array [0..MAX_PATH] of Char;
 begin
   GetModuleFileName( Instance, buffer, MAX_PATH);
   Result := buffer;
 end;
 
 GetModuleFileNameStr(Hinstance); // dll name
 GetModuleFileNameStr(0); // exe name
 




Как получить версию моей DLL

Приходит мужик в поликлинику - жаловаться на мужские проблемы, а там вместо врача - компьютер. Ну, он изложил суть проблем оператору, тот говорит:
- Вставьте член в отверстие сбоку. Мужик вставил. Комп погудел-погудел да и выдал: "Your Version Expired".


 procedure GetFileVersion(FileName: string; var Major1, Major2,
   Minor1, Minor2: Integer);
 var
   Info: Pointer;
   InfoSize: DWORD;
   FileInfo: PVSFixedFileInfo;
   FileInfoSize: DWORD;
   Tmp: DWORD;
 begin
   InfoSize := GetFileVersionInfoSize(PChar(FileName), Tmp);
 
   if InfoSize = 0 then
     //Файл не содержит информации о версии
   else
   begin
     GetMem(Info, InfoSize);
     try
       GetFileVersionInfo(PChar(FileName), 0, InfoSize, Info);
       VerQueryValue(Info, '\', Pointer(FileInfo), FileInfoSize);
       Major1 := FileInfo.dwFileVersionMS shr 16;
       Major2 := FileInfo.dwFileVersionMS and $FFFF;
       Minor1 := FileInfo.dwFileVersionLS shr 16;
       Minor2 := FileInfo.dwFileVersionLS and $FFFF;
     finally
       FreeMem(Info, FileInfoSize);
     end;
   end;
 end;
 




Как узнать автора файла документа

Автор: Asmith

Вот простой пример, подробности в MSDN:


 uses ActiveX, ComObj, SysUtils;
 
 function GetSummaryInfAuthor(FileName: TFileName): string;
 var
  PFileName: PWideChar;
  Storage: IStorage;
  PropSetStg: IPropertySetStorage;
  PropStg: IPropertyStorage;
  ps: PROPSPEC;
  pv: PROPVARIANT;
 const
  FMTID_SummaryInformation: TGUID = '{F29F85E0-4FF9-1068-AB91-08002B27B3D9}';
 begin
  PFileName := StringToOleStr(FileName);
  try
    // Open compound storage
    OleCheck(StgOpenStorage(PFileName, nil,
    STGM_DIRECT or STGM_READ or STGM_SHARE_EXCLUSIVE, nil, 0, Storage));
  finally
    SysFreeString(PFileName);
  end;
 
  // Summary information is in a stream under the root storage
  PropSetStg := Storage as IPropertySetStorage;
  // Get the IPropertyStorage
  OleCheck(PropSetStg.Open(FMTID_SummaryInformation,
  STGM_DIRECT or STGM_READ or STGM_SHARE_EXCLUSIVE, PropStg));
 
  // We want the author property value
  ps.ulKind := PRSPEC_PROPID;
  ps.propid := PIDSI_AUTHOR;
 
  // Read this property
  PropStg.ReadMultiple(1, @ps, @pv);
 
  Result := pv.pszVal;
 end;
 




Как получить доменное имя по IP

Спpашивает дочка у мамы:
- Мам, а кто этот волосатый дядя с кpасными глазками?
- Это твой папа, доченька.
- А он что, заболел?
- Да нет, он к интеpнету подключился.


 uses winsock;
 
 function IPAddrToName(IPAddr : string): string;
 var
   SockAddrIn: TSockAddrIn;
   HostEnt: PHostEnt;
   WSAData: TWSAData;
 begin
   WSAStartup($101, WSAData);
   SockAddrIn.sin_addr.s_addr:= inet_addr(PChar(IPAddr));
   HostEnt:= gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET);
   if HostEnt <> nil then
     result := StrPas(Hostent^.h_name)
   else
     result:='';
 end;
 
 //Пример использования
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Label1.Caption := IPAddrToName(Edit1.Text);
 end;
 




Как получить переменные окружения типа PATH и PROMPT


Хакер идет по улице, в руках держит BFG 9000. Навстречу ему братки крутые:
- Ты где такую феню взял, в натуре?!
А он лениво так:
- Да из Дума, Дебаггером дернул...

Для этого используется API функция GetEnvironmentVariable.

GetEnvironmentVariable возвращает значения:

  • В случае удачного выполнения функции, возвращаемое значение содержит количество символов, хранящихся в буфере, не включая последнего нулевого.
  • Если указанная переменная окружения для текущего процесса не найдена, то возвращаемое значение равно нулю.
  • Если буфер не достаточного размера, то возвращаемое значение равно требуемому размеру для хранения строки значения и завершающего нулевого символа.

 function GetDOSEnvVar(const VarName: string): string;
 var
   i: integer;
 begin
   Result := '';
   try
     i := GetEnvironmentVariable(PChar(VarName), nil, 0);
     if i > 0 then
     begin
       SetLength(Result, i);
       GetEnvironmentVariable(Pchar(VarName), PChar(Result), i);
     end;
   except
     Result := '';
   end;
 end;
 




Как получить переменные окружения типа PATH и PROMPT 2


 procedure TMainFrm.AddVarsToMemo(Sender: TObject);
 var
   p: pChar;
 begin
   Memo1.Lines.Clear;
   Memo1.WordWrap := false;
   p := GetEnvironmentStrings;
   while p^ <> #0 do
   begin
     Memo1.Lines.Add(StrPas(p));
     inc(p, lStrLen(p) + 1);
   end;
   FreeEnvironmentStrings(p);
 end;
 




Как получить строку сообщения об ошибке Windows код которой получен функцией GetLastError


Звонок на радио: - Поставьте, пожалуйста, песню Пугачевой про то, как у нее завис Windows! Ди-джей (после паузы): - Я не могу вспомнить у Пугачевой такой песни! Можете напеть? - ну, там еще в припеве: "Кликну, а в ответ тишина, снова я осталась одна... Сильная женщина плачет у Окна..."


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ShowMessage(IntToStr(lStrLen(nil)));
   ShowMessage(SysErrorMessage(GetLastError));
 end;
 




Получение значений полей из текстового файла


 var
   F: TextFile;
   S: string;
 begin
   AssignFile(F, 'FILENAME.TXT');
   Reset(F);
   while not EOF(F) do
   begin
     Readln(F, S);
     V1 := Copy(S, 1, 3);
     V2 := Copy(S, 4, 6);
     ...
   end;
   CloseFile(F);
 end;
 




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

Автор: Андрей Сорокин
WEB-сайт: http://anso.da.ru

Для использования этого объекта необходима библиотека TRegExpr


 {$B-}
 unit DirScan;
 
 interface
 
 uses
   RegExpr, SysUtils, Classes;
 
 type
   PDirectoryScannerItem = ^TDirectoryScannerItem;
   TDirectoryScannerItem = packed record
     name : string;
     Size : integer;
     LastWriteTime : TDateTime;
   end;
 
   TOnDirScanFileProceed = procedure (Sender : TObject; const ABaseFolder : string;
     const ASearchRecord : TSearchRec; var ACancel : boolean) of object;
   TOnDirScanStartFolderScanning = procedure (Sender : TObject; const AFolder : string) of object;
   TOnDirScanTimeSlice = procedure (Sender : TObject; var ACancel : boolean) of object;
 
   TCustomDirectoryScanner = class
     private
       fRegExprMask : string;
       fRecursive : boolean;
       fCount : integer;
       fOnFileProceed : TOnDirScanFileProceed;
       fOnStartFolderScanning : TOnDirScanStartFolderScanning;
       fOnTimeSlice : TOnDirScanTimeSlice;
       fMaskRegExpr : TRegExpr;
       function BuildFileListInt (const AFolder : string) : boolean;
     public
       constructor Create;
       destructor Destroy; override;
 
       property Recursive : boolean read fRecursive write fRecursive;
       property RegExprMask : string read fRegExprMask write fRegExprMask;
       // regular expresion for file names masks (like '(\.html?|\.xml)' etc)
       function BuildFileList (AFolder : string) : boolean;
       // Build list of all files in folder AFolder.
       // If ASubFolder = true then recursivly scans subfolders.
       // Returns false if there was file error and user
       // decided to terminate process.
 
       property Count : integer read fCount;
       // matched in last BuildFileList files count
 
       // Events
       property OnFileProceed : TOnDirScanFileProceed read fOnFileProceed write fOnFileProceed;
       // for each file matched
       property OnStartFolderScanning : TOnDirScanStartFolderScanning read fOnStartFolderScanning
         write fOnStartFolderScanning;
       // before scanning each directory (starting with root)
       property OnTimeSlice : TOnDirScanTimeSlice read fOnTimeSlice write fOnTimeSlice;
       // for progress bur an so on (called in each internal iteration)
   end;
 
   TDirectoryScanner = class (TCustomDirectoryScanner)
    // simple descendant - after BuildFileList call make list of files
    // (You can access list thru Item property)
    private
      fList : TList;
      function GetItem (AIdx : integer) : PDirectoryScannerItem;
      procedure KillItem (AIdx : integer);
      procedure FileProceeding (Sender : TObject; const ABaseFolder : string;
        const ASearchRecord : TSearchRec; var ACancel : boolean);
      procedure TimeSlice (Sender : TObject; var ACancel : boolean);
    public
      constructor Create;
      destructor Destroy; override;
 
      property Item [AIdx : integer] : PDirectoryScannerItem read GetItem;
   end;
 
 
 
 implementation
 
 uses
   Windows, Controls, TFUS;
 
 constructor TCustomDirectoryScanner.Create;
 begin
   inherited;
   fRecursive := true;
   fOnFileProceed := nil;
   fOnStartFolderScanning := nil;
   fOnTimeSlice := nil;
   fMaskRegExpr := nil;
   fRegExprMask := '';
 end; { of constructor TDirectoryScanner.Create}
 
 destructor TCustomDirectoryScanner.Destroy;
 begin
   fMaskRegExpr.Free;
   inherited;
 end; { of destructor TCustomDirectoryScanner.Destroy}
 
 function TCustomDirectoryScanner.BuildFileList (AFolder : string) : boolean;
 begin
   if (length (AFolder) > 0) and (AFolder [length (AFolder)] = '\')
    then AFolder := copy (AFolder, 1, length (AFolder) - 1);
 
   fMaskRegExpr := TRegExpr.Create;
   fMaskRegExpr.Expression := RegExprMask;
 
   fCount := 0;
   Result := BuildFileListInt (AFolder);
 end; { function BuildFileList}
 
 function TCustomDirectoryScanner.BuildFileListInt (const AFolder : string) : boolean;
 var
   sr : SysUtils.TSearchRec;
   Canceled : boolean;
 begin
   Result := true;
   if Assigned (OnStartFolderScanning)
    then OnStartFolderScanning (Self, AFolder + '\');
 
   if SysUtils.FindFirst (AFolder + '\' + '*.*', faAnyFile, sr) = 0 then try
        repeat
         try
            if (sr.Attr and SysUtils.faDirectory) = SysUtils.faDirectory then begin
              if Recursive and (sr.name <> '.') and (sr.name <> '..')
               then Result := BuildFileListInt (AFolder + '\' + sr.name);
              end
             else begin
                if fMaskRegExpr.Exec (sr.name) then begin
                 Canceled := false;
                 if Assigned (OnFileProceed)
                  then OnFileProceed (Self, AFolder, sr, Canceled);
                 if Canceled
                  then Result := false;
                 inc (fCount);
                end;
              end;
           except on E:Exception do begin
             case MsgBox ('Replacing error',
                   'Can''t replace file contetn due to error:'#$d#$a#$d#$a
                   + E.message + #$d#$a#$d#$a + 'Continue processing ?',
                   mb_YesNo or mb_IconQuestion) of
               mrYes : Result := false;
               >else ; // must be No
              end;
            end;
          end;
         Canceled := false;
         if Assigned (OnTimeSlice)
          then OnTimeSlice (Self, Canceled);
         if Canceled
          then Result := false;
        until not Result or (SysUtils.FindNext (sr) <> 0);
       finally SysUtils.FindClose (sr);
      end;
   if not Result
    then EXIT;
 end; { function BuildFileListInt}
 
 constructor TDirectoryScanner.Create;
 begin
   inherited;
   fList := TList.Create;
   OnFileProceed := FileProceeding;
   fOnTimeSlice := TimeSlice;
 end; { of constructor TDirectoryScanner.Create}
 
 destructor TDirectoryScanner.Destroy;
 var
   i : integer;
 begin
   for i := fList.Count - 1 downto 0 do
    KillItem (i);
   fList.Free;
   inherited;
 end; { of destructor TDirectoryScanner.Destroy}
 
 procedure TDirectoryScanner.KillItem (AIdx : integer);
 var
   p : PDirectoryScannerItem;
 begin
   p := PDirectoryScannerItem (fList.Items [AIdx]);
   Dispose (p);
   fList.Delete (AIdx);
 end; { of procedure TDirectoryScanner.KillItem}
 
 function TDirectoryScanner.GetItem (AIdx : integer) : PDirectoryScannerItem;
 begin
   Result := PDirectoryScannerItem (fList.Items [AIdx]);
 end; { of function TDirectoryScanner.GetItem}
 
 procedure TDirectoryScanner.FileProceeding (Sender : TObject; const ABaseFolder : string;
 const ASearchRecord : TSearchRec; var ACancel : boolean);
 var
   p : PDirectoryScannerItem;
 begin
   p := New (PDirectoryScannerItem);
   p.name := ABaseFolder + '\' + ASearchRecord.name;
   fList.Add (p);
 end; { of procedure TDirectoryScanner.FileProceeding}
 
 procedure TDirectoryScanner.TimeSlice (Sender : TObject; var ACancel : boolean);
 begin
   if Count mod 100 = 0
    then Sleep (0);
 end; { of procedure TDirectoryScanner.TimeSlice}
 
 end.
 




Получаем имена файлов, скопированных в буфер обмена


 procedure TForm1.Button1Click(Sender: TObject);
 var
   f: THandle;
   buffer: array [0..MAX_PATH] of Char;
   i, numFiles: Integer;
 begin
   if not Clipboard.HasFormat(CF_HDROP) then Exit;
   Clipboard.Open;
   try
     f := Clipboard.GetAsHandle(CF_HDROP);
     if f <> 0 then
     begin
       numFiles := DragQueryFile(f, $FFFFFFFF, nil, 0);
       memo1.Clear;
       for i := 0 to numfiles - 1 do
       begin
         buffer[0] := #0;
         DragQueryFile(f, i, buffer, SizeOf(buffer));
         memo1.Lines.Add(buffer);
       end;
     end;
   finally
     Clipboard.Close;
   end;
 end;
 




Получение размера файла

Автор: Eric Nielsen

Вот мой код, которым я пользуюсь для определения информации о группе файлов:


 var
   Fhnd2: file;
   sPath: string;
   tpath: string;
   SearchRec: TSearchRec;
   tempsearch: string;
   tempfiles: Integer;
   tempbytes: LongInt;
   wBytes: Word;
   sTemp: string;
   iLen: Integer;
   szString: array[0..128] of Char;
   ec: integer;
 begin
   {* Выбираем системный каталог *}
   MailManLogS('Запуск MailMan');
   sTemp := ParamStr(0);
   iLen := Length(sTemp);
   while sTemp[iLen] <> '\' do
     DEC(iLen);
   StrPCopy(szString, sTemp);
   szString[iLen] := #0;
   SysDir := StrPas(szString);
 
   tempbytes := 0;
   tempfiles := 0;
   Files2bProc := 0;
   Bytes2bProc := 0;
   MailManLogS('Калькулируем файлы для обработки');
   {* Подсчитываем, сколько файлов и байт должны быть обработаны *}
   tempsearch := SysDir + 'spool\witchcrf\d\*.*';
   ec := FindFirst(tempsearch, faSysFile, SearchRec);
   while ec = 0 do
   begin
     if ((SearchRec.Name <> '.') and (SearchRec.Name <> '..')) then
     begin
       tempfiles := tempfiles + 1;
       - - - - > tempbytes := tempbytes + SearchRec.Size;
       < - - - - - -
 
       TotalInBytes.Text := IntToStr(tempbytes);
       TotalInFiles.Text := IntToStr(tempfiles);
       MailManLogS('Файл-' + SearchRec.Name + '     Размер-' +
         IntToStr(SearchRec.Size));
 
     end;
     ec := FindNext(SearchRec);
   end;
 
   MailManLogS('Всего файлов = ' + IntToStr(tempfiles) + '        Байт = ' +
     IntToStr(tempbytes));
 end;
 

В коде могут присутствовать синтаксические ошибки, т.к. я просто вырезал этот код из своей программы, чтобы показать как работает функция FindFirst. Она должна возвращать информацию о файле в SearchRec, который будет содержать любую необходимую вам информацию о файле. Я думаю это то, что вам нужно, при этом нет необходимости даже открывать файл.

Я все это делал с использованием FindFirst. Функция возвращает запись, имеющую тип TSearchRec. Данная запись содержит переменную Size, которая содержит размер файла в байтах. Это может быть не так красиво, но это работает:


 function GetFileSize(FileName: string): Longint;
 var
   SearchRec: TSearchRec;
 begin
   if FindFirst(FileName, faAnyFile, SearchRec) = 0 then
     Result:=SearchRec.Size
   else
     Result:=-1; {возвращаем ошибку, это может быть число меньше нуля}
 end;
 

В зависимости от предпочтений, можно выбрать одну из двух приведенных ниже функций. В первой реализуется идея временного изменения атрибутов файла, необходимого для его чтения. Вторая использует Windows API, но не содержит средств проверки наличия ошибок.


 function FileGetSize1(Filename: string): LongInt;
 var
   F: file;
   OldFileAttr: Integer;
 begin
   if FileExists(Filename) then
   begin
     OldFileAttr := FileGetAttr(Filename);
     FileSetAttr(Filename, OldFileAttr and (faReadOnly xor $FFFF));
     try
       AssignFile(F, Filename);
       Reset(F, 1);
       Result := FileSize(F);
       CloseFile(F);
     finally
       FileSetAttr(Filename, OldFileAttr);
     end;
   end
   else
     Result := 0;
 end;
 
 function FileGetSize2(Filename: string): LongInt;
 var
   FileHandle: Integer;
 begin
   if FileExists(Filename) then
   begin
     FileName := FileName + chr(0);
     FileHandle := _lopen(@FileName[1], 0);
     Result := _llseek(FileHandle, 0, 2);
     _lclose(FileHandle);
   end
   else
     Result := 0;
 end;
 

Я не стал возиться с AssignFile.


 Function FileSizeInBytes(YourFile : String) : LongInt;
 Var
   F: Integer;
 Begin
   F:=FileOpen(YourFile,0);  { режим ReadOnly }
   FilesizeInBytes := FileSeek(F,0,2);
   FileClose(F)
 End;
 

Примечание: Проверка ошибок отсутствует !!!




Как определить размер файла


 // Если файл не существует, то вместо размера файла функция верн¸т -1
 function GetFileSize(FileName: String): Integer;
 var
   FS: TFileStream;
 begin
   try
     FS := TFileStream.Create(Filename, fmOpenRead);
   except
     Result := -1;
   end;
   if Result <> -1 then Result := FS.Size;
   FS.Free;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   ShowMessage(IntToStr(GetFileSize('c:\prova.pdf')));
 end;
 




Как определить размер файла 2

Автор: Andrey


 function GetFileSize(namefile: string): Integer;
 var
   InfoFile: TSearchRec;
   AttrFile: Integer;
   ErrorReturn: Integer;
 begin
   AttrFile := $0000003F; {Any file}
   ErrorReturn := FindFirst(namefile, AttrFile, InfoFile);
   if ErrorReturn <> 0 then
     Result := -1 {в случае, если файл не найден}
   else
     Result := InfoFile.Size; {Размер файла в байтах}
   FindClose(InfoFile);
 end;
 




Как определить размер файла 3


 function GetFileSizeByName(FileName: String): Integer;
 var
   FindData: TWin32FindData;
   hFind: THandle;
 begin
   Result := -1;
   hFind := FindFirstFile(PChar(FileName), FindData);
   if hFind <> INVALID_HANDLE_VALUE then
   begin
     Windows.FindClose(hFind);
     if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
       Result := FindData.nFileSizeLow;
   end;
 end;
 




Как получить дескриптор текущего окна


 HWND GetForegroundWindow(VOID);
 




Получить имена свободных com портов

Для начала подключите модуль Registry в области uses. Затем на форму нужно будет вынести кнопку и многострочное текстовое поле класса TMemo. Ну и по нажатию на кнопку написать следующий код:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   reg: TRegistry;
   st: TStrings;
   i: integer;
 begin
   reg := TRegistry.Create;
   reg.RootKey := HKEY_LOCAL_MACHINE;
   reg.OpenKey('hardware\devicemap\serialcomm', false);
   st := TStringList.Create;
   reg.GetValueNames(st);
   for i := 0 to st.Count - 1 do
     Memo1.Lines.Add(reg.ReadString(st.Strings[i]));
   st.Free;
   reg.CloseKey;
   reg.free;
 end;
 




Как получить хэндлы всех пpоцессов, котоpые запущены на данный момент в системе

Под Windows 95 это возможно с использованием вспомогательных инфоpмационных функций (tool help functions). Для получения списка пpоцессов надо делать следующее:


 // Получение снимка состояния системы
 hSnapshot := CreateToolhelp32Snapshot (TH32CS_SNAPPROCESS, 0);
 // Получене инфоpмации о пеpвом пpоцессе в списке
 Process32First();
 // Получение инфоpмации о следующем пpоцессе в списке
 Далее в цикле Process32Next();
 


 unit KernlUtl;
 
 interface
 
 uses
   TlHelp32, Windows, Classes, Sysutils;
 
   procedure GetProcessList(List: TStrings);
   procedure GetModuleList(List: TStrings);
   function GetProcessHandle(ProcessID: DWORD): THandle;
   procedure GetParentProcessInfo(var ID: DWORD; var Path: string);
 
 const
   PROCESS_TERMINATE = $0001;
   PROCESS_CREATE_THREAD = $0002;
   PROCESS_VM_OPERATION = $0008;
   PROCESS_VM_READ = $0010;
   PROCESS_VM_WRITE = $0020;
   PROCESS_DUP_HANDLE = $0040;
   PROCESS_CREATE_PROCESS = $0080;
   PROCESS_SET_QUOTA = $0100;
   PROCESS_SET_INFORMATION = $0200;
   PROCESS_QUERY_INFORMATION = $0400;
   PROCESS_ALL_ACCESS =
   STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $0FFF;
 
 implementation
 
 procedure GetProcessList(List: TStrings);
 var
   I: Integer;
   hSnapshoot: THandle;
   pe32: TProcessEntry32;
 begin
   List.Clear;
   hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
 
   if (hSnapshoot = -1) then
     Exit;
   pe32.dwSize := SizeOf(TProcessEntry32);
   if (Process32First(hSnapshoot, pe32)) then
     repeat
       I := List.Add(Format('%x, %x: %s',
       [pe32.th32ProcessID, pe32.th32ParentProcessID, pe32.szExeFile]));
       List.Objects[I] := Pointer(pe32.th32ProcessID);
     until
       not Process32Next(hSnapshoot, pe32);
 
   CloseHandle (hSnapshoot);
 end;
 
 procedure GetModuleList(List: TStrings);
 var
   I: Integer;
   hSnapshoot: THandle;
   me32: TModuleEntry32;
 begin
   List.Clear;
   hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, 0);
   if (hSnapshoot = -1) then
     Exit;
   me32.dwSize := SizeOf(TModuleEntry32);
   if (Module32First(hSnapshoot, me32)) then
     repeat
       I := List.Add(me32.szModule);
       List.Objects[I] := Pointer(me32.th32ModuleID);
     until
       not Module32Next(hSnapshoot, me32);
 
   CloseHandle (hSnapshoot);
 end;
 
 procedure GetParentProcessInfo(var ID: DWORD; var Path: string);
 var
   ProcessID: DWORD;
   hSnapshoot: THandle;
   pe32: TProcessEntry32;
 begin
   ProcessID := GetCurrentProcessID;
   ID := -1;
   Path := '';
 
   hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
 
   if (hSnapshoot = -1) then
     Exit;
 
   pe32.dwSize := SizeOf(TProcessEntry32);
   if (Process32First(hSnapshoot, pe32)) then
     repeat
       if pe32.th32ProcessID = ProcessID then
       begin
         ID := pe32.th32ParentProcessID;
         Break;
       end;
     until
       not Process32Next(hSnapshoot, pe32);
 
   if ID <> -1 then
   begin
     if (Process32First(hSnapshoot, pe32)) then
       repeat
         if pe32.th32ProcessID = ID then
         begin
           Path := pe32.szExeFile;
           Break;
         end;
       until
         not Process32Next(hSnapshoot, pe32);
   end;
   CloseHandle (hSnapshoot);
 end;
 
 function GetProcessHandle(ProcessID: DWORD): THandle;
 begin
   Result := OpenProcess(PROCESS_ALL_ACCESS, True, ProcessID);
 end;
 
 end.
 




Получить Handle и имя класса окна под мышкой

Перевод куска текста к "хелпу" Win'95 без основного словаря переводчиком Poliglossum с медицинским, коммерческим и юридическим словарем). Microsoft компания получает много откликов после появления Окон 95. Мы выявили, что много пользователей встретили проблему мыши. В этом документе Служба Техничного Упора Microsoft компании сводит вместе всю полезную информацию о возможных проблемах с мышами и гуртовщиками мыши и забота-стреляние. Если вы только что закрепили себе Окна 95, вы можете увидеть, что ваша мышь плохо себя ведет. Курсор может не двигаться или движение мыши может проявлять странные следы на поверхности стола, окнах и обоях. Мышь может неадекватно реагировать на щелчок по почкам. Но не спешите! Это могут быть физические проблемы, а не клоп Окон 95. Почистите вашу мышь. Отсоедините ее поводок от компьютера, вытащите гениталий и промойте его и ролики внутренностей спиртом. Снова зашейте мышь. Проверьте на переломы поводка. Подсоедините мышь к компьютеру. Приглядитесь к вашей прокладке (подушке) - она не должна быть источником мусора и пыли в гениталии и роликах. Поверхность прокладки не должна стеснять движения мыши. Может быть вам стоит купить новую мышь. Мы настоятельно рекомендуем Microsoft мышь. Она эргономично спроектирована, особо сделана под Окна 95 и имеет третью почку в виде колеса, которые могут завивать окна. Совокупление Microsoft мыши и Окон 95 делает вашу повседневную работу легко приятной. Испытайте все это. Если проблемы остались - ваш гуртовщик мыши плохо стоит под Окнами 95. Его придется убрать. Вам нужен новый гуртовщик мыши. Если вы пользователь Microsoft мыши посетите Microsoft Слугу Паутины, где в особом подвале вы сможете опустить-загрузить самого текущего гуртовщика Microsoft мыши. Если производитель вашей мыши другой, узнайте о ее гуртовщике. Все основные производители мыши уже имеют гуртовщиков мыши для Окон 95. Перед тем как вы будете закреплять гуртовщика мыши, сделайте заднюю-верхнюю копию ваших досье. Почистить ваш винчестер имеет смысл. У вас должен быть старт-вверх диск от Окон 95. После того, как вы закрепили нового гуртовщика, скорее всего ваши проблемы решены. Если они остались, напишите в Службу Техничного Упора Microsoft, и вашим случаем займется Особый Отдел. Для эффективной помощи техничного упора, наш инженер должен знать торговую марку вашей мыши, тип (в-портовая мышь, периодическая мышь, автобусная мышь, Полицейский Участок /2 мышь, без поводка мышь, гениталий на гусеничном ходу и т. п.), версию гуртовщика, производителя компьютера (матери-доски), положение портов и рубильников на матери-доске (и расклад карт), а также содержимое досье Авто-#####.bat, config.sys и Сапог-полено.txt. Кроме того, несколько полезных советов: 1) Не закрепляйте себе Окна 95 в то же самое место, где у вас закреплены Окна 3. икс, вы не сможете хорошо делать кое-что привычное. 2) Eсли вы новичок под Окнами 95, привыкните к новым возможностям мыши. Щелкните по левой почке - выделите пункт, ударьте по правой почке меню с контекстом всплывет, быстро ударьте два раза по левой почке - запустите повестку в суд. 4) Oтработайте быстрый двойной удар по почкам мыши с помощью специального тренажера на пульте управления Окнами 95. 6) Cпециалисты Microsoft компании после большого числа опытов выявили, что наиболее эффективной командой из-под Окон 95 является "Послать на...", которая доступна в любом времени и месте при ударе по правой почке мыши. Если вы только что закрепили себе окна 95, вы сумеете послать только на А (Б) и в специальное место "Мой портфель". Но по мере того как вы будете закреплять себе новые программы для Окон 95, вы начнете посылать на все более сложные и интересные места и объекты. Особую эффективность команда "Послать на..." приобретет при передачи посланий через Е-почту и общение с вашими коллегами и друзьями в местной сети-работе. Попробуйте мощь команды "Послать на...", и вы быстро убедитесь, что без нее трудно существовать под Окнами 95. Пишите нам и помните, что Microsoft компания всегда думает о том, как ВАС ЛУЧШЕ СДЕЛАТЬ.


 type
   TForm1 = class(TForm)
     Label1: TLabel;
     Label2: TLabel;
     Timer1: TTimer;
     procedure Timer1Timer(Sender: TObject);
     procedure FormCreate(Sender: TObject);
   private
     procedure ShowHwndAndClassName(CrPos: TPoint);
   public
 
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.Timer1Timer(Sender: TObject);
 var
   rPos: TPoint;
 begin
   if Boolean(GetCursorPos(rPos)) then ShowHwndAndClassName(rPos);
 end;
 
 procedure TForm1.ShowHwndAndClassName(CrPos: TPoint);
 var
   hWnd: THandle;
   aName: array [0..255] of Char;
 begin
   hWnd := WindowFromPoint(CrPos);
   Label1.Caption := 'Handle :  ' + IntToStr(hWnd);
 
   if Boolean(GetClassName(hWnd, aName, 256)) then
     Label2.Caption := 'ClassName :  ' + string(aName)
   else
     Label2.Caption := 'ClassName :  not found';
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Form1.FormStyle := fsStayOnTop;
   Timer1.Interval := 50;
 end;
 




Получить серийный номер диска

Куплю винчестер. Жёсткие диски не предлагать.


 function GetHardDiskSerial(const DriveLetter: Char): string;
 var
   NotUsed:     DWORD;
   VolumeFlags: DWORD;
   VolumeInfo:  array[0..MAX_PATH] of Char;
   VolumeSerialNumber: DWORD;
 begin
   GetVolumeInformation(PChar(DriveLetter + ':\'),
     nil, SizeOf(VolumeInfo), @VolumeSerialNumber, NotUsed,
     VolumeFlags, nil, 0);
   Result := Format('Label = %s   VolSer = %8.8X',
     [VolumeInfo, VolumeSerialNumber])
 end;
 
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ShowMessage(GetHardDiskSerial('c'));
 end;
 




Получить серийный номер диска 2


 procedure TForm1.Button1Click(Sender: TObject);
 var
   VolumeName,
     FileSystemName: array[0..MAX_PATH - 1] of Char;
   VolumeSerialNo: DWord;
   MaxComponentLength,
     FileSystemFlags: Integer;
 begin
   GetVolumeInformation('C:\', VolumeName, MAX_PATH, @VolumeSerialNo,
     MaxComponentLength, FileSystemFlags,
     FileSystemName, MAX_PATH);
   Memo1.Lines.Add('VName = ' + VolumeName);
   Memo1.Lines.Add('SerialNo = $' + IntToHex(VolumeSerialNo, 8));
   Memo1.Lines.Add('CompLen = ' + IntToStr(MaxComponentLength));
   Memo1.Lines.Add('Flags = $' + IntToHex(FileSystemFlags, 4));
   Memo1.Lines.Add('FSName = ' + FileSystemName);
 end;
 




Как получить полный исходник HTML

Автор: Ron Loewy

Hасколько проще была бы жизнь, если бы она была в исходниках.

В IE5, можно получить исходник используя свойство outerHTML тэгов HTML. В IE4 или IE3, Вам понадобится записать документ в файл, а затем загрузить файл в TMemo, TStrings, и т.д.


 var
   HTMLDocument: IHTMLDocument2;
   PersistFile: IPersistFile;
 begin
   ...
   HTMLDocument := WebBrowser1.Document as IHTMLDocument2;
   PersistFile := HTMLDocument as IPersistFile;
   PersistFile.Save(StringToOleStr('test.htm'), True);
 
   while HTMLDocument.readyState <> 'complete' do
     Application.ProcessMessages;
  ...
 end;
 

Обратите внимание: Вам понадобится импортировать библиотеку MSHTML и добавить MSHTML_TLB как ActiveX, в секцию Uses.




Получение иконки из ICO, EXE, DLL

Богоматерь.ico

Процесс получения иконок из .EXE, .DLL или .ICO файлов полностью идентичен. Различие только в том, что в .ICO файле может храниться только одна иконка, а в .EXE и .DLL несколько. Для получения иконок из файлов, в модуле ShellAPI, есть функция:


 function ExtractIcon(Inst: THandle; FileName: PChar; IconIndex: Word): HIcon;
 

где

Inst
указатель на приложение вызвавшее функцию,
FileName
имя файла из которого необходимо получить иконку,
IconIndex
номер необходимой иконки.

Если функция возвращает значение не равное нулю, то в файле есть следующая иконка.

В данном примере в компонент Image1 выводится иконка запущенного файла.


 uses ShellAPI;
 ...
 procedure TForm1.FormCreate(Sender: TObject);
 var
   A: array [0..78] of Char;
 begin
   {Получение имени запущенного файла}
   StrPCopy(A, ParamStr(0));
   {Вывод на экран нулевой иконки из файла}
   Image1.Picture.Icon.Handle := ExtractIcon(HInstance, A, 0);
 end;
 

Если вы хотите создать некий браузер по иконкам, то можете воспользоваться компонентами с закладки Win3.1. Вынесите на форму компонент TFileListBox; затем TDirectoryListBox, в свойстве FileList укажите на список файлов [TFileListBox]; после этого возьмите компонент класса TDriveComboBox, указав в его свойстве DirList на список каталогов [TDirectoryListBox], ну, и, наконец, ставьте TFilterComboBox, который позволит в списке файлов отображать только те файлы, которые соответствуют маске, указанной в свойстве Filter. Здесь в качестве значения укажите следующее: ico|*.ico|dll|*.dll|exe|*.exe|all|*.ico; *.dll; *.exe ..а в свойстве FileList задайте список файлов [TFileListBox]. В обработчике OnClick компонента TFileListBox напишите такой код:


 var
   A: array [0..78] of Char;
 begin
   {Получение имени файла, указанного в списке файлов}
   StrPCopy(A, FileListBox1.FileName);
   {Вывод на экран нулевой иконки из файла}
   Image1.Picture.Icon.Handle := ExtractIcon(HInstance, A, 0);
 




Получение иконки из ICO, EXE, DLL 2

Сначала в разделе interface пишем такой код:


 type ThIconArray = array[0..0] of hIcon;
 type PhIconArray = ^ThIconArray;
 
 function ExtractIconExA(lpszFile: PAnsiChar;
   nIconIndex: Integer;
   phiconLarge : PhIconArray;
   phiconSmall: PhIconArray;
   nIcons: UINT): UINT; stdcall;
   external 'shell32.dll' name 'ExtractIconExA';
 
 function ExtractIconExW(lpszFile: PWideChar;
   nIconIndex: Integer;
   phiconLarge: PhIconArray;
   phiconSmall: PhIconArray;
   nIcons: UINT): UINT; stdcall;
   external 'shell32.dll' name 'ExtractIconExW';
 
 function ExtractIconEx(lpszFile: PAnsiChar;
   nIconIndex: Integer;
   phiconLarge : PhIconArray;
   phiconSmall: PhIconArray;
   nIcons: UINT): UINT; stdcall;
   external 'shell32.dll' name 'ExtractIconExA';
 

Затем по нажатию на кнопку:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   NumIcons: integer;
   pTheLargeIcons: phIconArray;
   pTheSmallIcons: phIconArray;
   LargeIconWidth: integer;
   SmallIconWidth: integer;
   SmallIconHeight: integer;
   i: integer;
   TheIcon: TIcon;
   TheBitmap: TBitmap;
 begin
   NumIcons :=
   ExtractIconEx('C:\Program Files\Borland\Delphi 3\BIN\delphi32.exe',
     -1, nil, nil, 0);
   if NumIcons > 0 then
   begin
     LargeIconWidth := GetSystemMetrics(SM_CXICON);
     SmallIconWidth := GetSystemMetrics(SM_CXSMICON);
     SmallIconHeight := GetSystemMetrics(SM_CYSMICON);
     GetMem(pTheLargeIcons, NumIcons * sizeof(hIcon));
     GetMem(pTheSmallIcons, NumIcons * sizeof(hIcon));
     FillChar(pTheLargeIcons^, NumIcons * sizeof(hIcon), #0);
     FillChar(pTheSmallIcons^, NumIcons * sizeof(hIcon), #0);
     ExtractIconEx('C:\Program Files\Borland\Delphi 3\BIN\delphi32.exe',
       0, pTheLargeIcons, pTheSmallIcons, numIcons);
     {$IFOPT R+}
     {$DEFINE CKRANGE}
     {$R-}
     {$ENDIF}
     for i := 0 to (NumIcons - 1) do
     begin
       DrawIcon(Form1.Canvas.Handle, i * LargeIconWidth, 0, pTheLargeIcons^[i]);
       TheIcon := TIcon. Create;
       TheBitmap := TBitmap.Create;
       TheIcon.Handle := pTheSmallIcons^[i];
       TheBitmap.Width := TheIcon.Width;
       TheBitmap.Height := TheIcon.Height;
       TheBitmap.Canvas.Draw(0, 0, TheIcon);
       TheIcon.Free;
       Form1.Canvas.StretchDraw(Rect(i * SmallIconWidth,
         100, (i + 1) * SmallIconWidth, 100 + SmallIconHeight), TheBitmap);
       TheBitmap.Free;
     end;
     {$IFDEF CKRANGE}
     {$UNDEF CKRANGE}
     {$R+}
     {$ENDIF}
     FreeMem(pTheLargeIcons, NumIcons * sizeof(hIcon));
     FreeMem(pTheSmallIcons, NumIcons * sizeof(hIcon));
   end;
 end;
 




Получаем ID3Tag v1


 {
   Byte 1-3 = ID 'TAG'
   Byte 4-33 = Titel / Title
   Byte 34-63 = Artist
   Byte 64-93 = Album
   Byte 94-97 = Jahr / Year
   Byte 98-127 = Kommentar / Comment
   Byte 128 = Genre
 }
 
 
 type
   TID3Tag = record
     ID: string[3];
     Titel: string[30];
     Artist: string[30];
     Album: string[30];
     Year: string[4];
     Comment: string[30];
     Genre: Byte;
   end;
 
 const
  Genres : array[0..146] of string =
     ('Blues','Classic Rock','Country','Dance','Disco','Funk','Grunge',
     'Hip- Hop','Jazz','Metal','New Age','Oldies','Other','Pop','R&B',
     'Rap','Reggae','Rock','Techno','Industrial','Alternative','Ska',
     'Death Metal','Pranks','Soundtrack','Euro-Techno','Ambient',
     'Trip-Hop','Vocal','Jazz+Funk','Fusion','Trance','Classical',
     'Instrumental','Acid','House','Game','Sound Clip','Gospel','Noise',
     'Alternative Rock','Bass','Punk','Space','Meditative','Instrumental Pop',
     'Instrumental Rock','Ethnic','Gothic','Darkwave','Techno-Industrial','Electronic',
     'Pop-Folk','Eurodance','Dream','Southern Rock','Comedy','Cult','Gangsta',
     'Top 40','Christian Rap','Pop/Funk','Jungle','Native US','Cabaret','New Wave',
     'Psychadelic','Rave','Showtunes','Trailer','Lo-Fi','Tribal','Acid Punk',
     'Acid Jazz','Polka','Retro','Musical','Rock & Roll','Hard Rock','Folk',
     'Folk-Rock','National Folk','Swing','Fast Fusion','Bebob','Latin','Revival',
     'Celtic','Bluegrass','Avantgarde','Gothic Rock','Progressive Rock',
     'Psychedelic Rock','Symphonic Rock','Slow Rock','Big Band','Chorus',
     'Easy Listening','Acoustic','Humour','Speech','Chanson','Opera',
     'Chamber Music','Sonata','Symphony','Booty Bass','Primus','Porn Groove',
     'Satire','Slow Jam','Club','Tango','Samba','Folklore','Ballad',
     'Power Ballad','Rhytmic Soul','Freestyle','Duet','Punk Rock','Drum Solo',
     'Acapella','Euro-House','Dance Hall','Goa','Drum & Bass','Club-House',
     'Hardcore','Terror','Indie','BritPop','Negerpunk','Polsk Punk','Beat',
     'Christian Gangsta','Heavy Metal','Black Metal','Crossover','Contemporary C',
     'Christian Rock','Merengue','Salsa','Thrash Metal','Anime','JPop','SynthPop');
 
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.dfm}
 
 function readID3Tag(FileName: string): TID3Tag;
 var
   FS: TFileStream;
   Buffer: array [1..128] of Char;
 begin
   FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
   try
     FS.Seek(-128, soFromEnd);
     FS.Read(Buffer, 128);
     with Result do
     begin
       ID      := Copy(Buffer, 1, 3);
       Titel   := Copy(Buffer, 4, 30);
       Artist  := Copy(Buffer, 34, 30);
       Album   := Copy(Buffer, 64, 30);
       Year    := Copy(Buffer, 94, 4);
       Comment := Copy(Buffer, 98, 30);
       Genre   := Ord(Buffer[128]);
     end;
   finally
     FS.Free;
   end;
 end;
 
 procedure TfrmMain.Button1Click(Sender: TObject);
 begin
   if OpenDialog1.Execute then
   begin
     with readID3Tag(OpenDialog1.FileName) do
     begin
       LlbID.Caption := 'ID: ' + ID;
       LlbTitel.Caption := 'Titel: ' + Titel;
       LlbArtist.Caption := 'Artist: ' + Artist;
       LlbAlbum.Caption := 'Album: ' + Album;
       LlbYear.Caption := 'Year: ' + Year;
       LlbComment.Caption := 'Comment: ' + Comment;
       if (Genre >= 0) and (Genre <=146) then
        LlbGenre.Caption := 'Genre: ' + Genres[Genre]
       else
        LlbGenre.Caption := 'N/A';
     end;
   end;
 end;
 




Как получить закладки IE


Встречаются два ярых интернетчика... Один - другому: - Слуууухай... Вчера на Мясницкой таакууую деевушку встретил... Познакомится не успел... :о( Гдееее её теперь искать.... Тот ему: - Не, ну ты чё, её букмаркой не заложил, что ль???


 function GetIEFavourites(const favpath: string): TStrings;
 var
   searchrec: TSearchrec;
   str: TStrings;
   path, dir, filename: string;
   Buffer: array [0..2047] of Char;
   found: Integer;
 begin
   str := TStringList.Create;
   //Get all file names in the favourites path
   path := FavPath + '\*.url';
   dir := ExtractFilepath(path);
   found := FindFirst(path, faAnyFile, searchrec);
   while found = 0 do
   begin
     //Get now URLs from files in variable files
     SetString(filename, Buffer, GetPrivateProfileString('InternetShortcut',
       PChar('URL'), nil, Buffer, SizeOf(Buffer), PChar(dir+searchrec.name)));
     str.Add(filename);
     found := FindNext(searchrec);
   end;
   //unterordner finden
   found := FindFirst(dir + '\*.*', faAnyFile, searchrec);
   while found=0 do
   begin
     if ((searchrec.Attr and faDirectory) > 0) and (searchrec.name[1] <> '.') then
       str.AddStrings(GetIEFavourites(dir + '\' + searchrec.name));
     found := FindNext(searchrec);
   end;
   FindClose(searchrec);
   Result := str;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   pidl: PItemIDList;
   FavPath: array [0..MAX_PATH] of char;
 begin
   SHGetSpecialFolderLocation(Handle, CSIDL_FAVORITES, pidl);
   SHGetPathFromIDList(pidl, favpath);
   ListBox1.Items := GetIEFavourites(StrPas(FavPath));
 end;
 




Извлечение изображения из BLOB-поля

- Почему программеры, сисопы и прочий компьютерный люд, всё время пьют пиво или ещё чего покрепче?
- А вы пробовали смотреть на работу чайника за компьютером на трезвую голову?

Извлечение изображения из BLOB-поля таблицы dBASE или Paradox -- без первой записи изображения в файл -- простейший процесс использования метода Assign для сохранения содержимого BLOB-поля в объекте, имеющим тип TBitmap. Отдельный объект TBitmap или свойство Bitmap объекта Picture, в свою очередь являющегося свойством компонента TIMage, могут служить примером совместимой цели для данной операции.

Вот пример кода, демонстрирующего использование метода Assign для копирования изображения из BLOB-поля в компонент TImage.


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Image1.Picture.Bitmap.Assign(Table1Bitmap);
 end;
 

В данном примере, объект Table1Bitmap типа TBLOBField - BLOB-поле таблицы dBASE. Данный TBLOBField-объекты был создан с помощью редактора полей (Fields Editor). Если редактор полей для создания TFields для полей таблицы не используется, получить доступ к полям можно с помощью метода FieldByName или свойства Fields, оба они являются членами компонентов TTable или TQuery. В случае ссылки на BLOB-поле таблицы с помощью одного из приведенных членов, перед использованием метода Assign указатель на поле должен быть прежде приведен к типу объекта TBLOBField. Для примера:


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Image1.Picture.Bitmap.Assign(TBLOBField(Table1.Fields[1]));
 end;
 

Изображение, хранящееся в BLOB-поле, может быть скопировано непосредственно в отдельный TBitmap объект. Ниже приведен пример, демонстрирующий создание объекта TBitmap и сохранения в нем изображения из BLOB-поля.


 procedure TForm1.Button2Click(Sender: TObject);
 var
   B: TBitmap;
 begin
   B := TBitmap.Create;
   try
     B.Assign(Table1Bitmap);
     Image1.Picture.Bitmap.Assign(B);
   finally
     B.Free;
   end;
 end;
 




Получить картинки из MessageDlg



 procedure TForm1.Button1Click(Sender: TObject);
 var
   Ic: TIcon;
 begin
   Ic := TIcon.Create;
   Ic.Handle := LoadIcon(0, IDI_APPLICATION);
   Form1.Canvas.Draw(1, 1, Ic);
   Ic.Handle := LoadIcon(0, IDI_ASTERISK);
   Form1.Canvas.Draw(32, 1, Ic);
   Ic.Handle := LoadIcon(0, IDI_EXCLAMATION);
   Form1.Canvas.Draw(64, 1, Ic);
   Ic.Handle := LoadIcon(0, IDI_QUESTION);
   Form1.Canvas.Draw(1, 32, Ic);
   Ic.Handle := LoadIcon(0, IDI_HAND);
   Form1.Canvas.Draw(32, 32, Ic);
   Ic.Handle := LoadIcon(0, IDI_WINLOGO);
   Form1.Canvas.Draw(64, 32, Ic);
   Ic.Destroy;
 end;
 




Захват части изображения

Автор: Mike Scott

Вот пример кода, позволящего с помощью TBitmap захватить часть изображения и сохранить его в файле. Я включил функцию копирования палитры, необходимой при работе в режиме 256 цветов.


 function CopyPalette(Palette: HPalette): HPalette;
 var
   nEntries: integer;
   LogPalSize: integer;
   LogPalette: PLogPalette;
 begin
   Result := 0;
   if Palette = 0 then
     exit;
   GetObject(Palette, sizeof(nEntries), @nEntries);
   if nEntries < 1 then
     exit;
   LogPalSize := sizeof(TLogPalette) + sizeof(TPaletteEntry) * (nEntries - 1);
   GetMem(LogPalette, LogPalSize);
   with LogPalette^ do
   try
     palVersion := $300;
     palNumEntries := nEntries;
     GetPaletteEntries(Palette, 0, nEntries, palPalEntry[0]);
     Result := CreatePalette(LogPalette^);
   finally
     FreeMem(LogPalette, LogPalSize);
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   Bitmap: TBitmap;
 begin
   Bitmap := TBitmap.Create;
   try
     Bitmap.Width := 50;
     Bitmap.Height := 40;
     Bitmap.Palette := CopyPalette(Image1.Picture.Bitmap.Palette);
     Bitmap.Canvas.CopyRect(Rect(0, 0, 50, 40),
       Image1.Picture.Bitmap.Canvas,
       Bounds(20, 10, 50, 40));
     Bitmap.SaveToFile('c:\windows\temp\junk.bmp');
   finally
     Bitmap.Free;
   end;
 end;
 




Получить тип интернет соединения

Афоризм дня: Возвращается муж домой из Интернета...


 uses
   WinInet;
 
 const
   MODEM = 1;
   LAN = 2;
   PROXY = 4;
   BUSY = 8;
 
 function GetConnectionKind(var strKind: string): Boolean;
 var
   flags: DWORD;
 begin
   strKind := '';
   Result := InternetGetConnectedState(@flags, 0);
   if Result then
   begin
     if (flags and MODEM) = MODEM then strKind := 'Modem';
     if (flags and LAN) = LAN then strKind := 'LAN';
     if (flags and PROXY) = PROXY then strKind := 'Proxy';
     if (flags and BUSY) = BUSY then strKind := 'Modem Busy';
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   strKind: string;
 begin
   if GetConnectionKind(strKind) then
     ShowMessage(strKind);
 end;
 




Как при создании объекта TThread передать ему некоторое значение

Антивирус для Windows - я выбираю безопасный секс!

К примеру, функция "прослушивает" каталог на предмет файлов. Если находит, то создает нить, которая будет обрабатывать файл. Потомку надо передать имя файла, а вот как?

Странный вопрос. Я бы понял, если бы требовалось передавать данные во время работы нити. А так обычно поступают следующим образом.

В объект нити, происходящий от TThread дописывают поля. Как правило, в секцию PRIVATE. Затем переопределяют конструктор CREATE, который, принимая необходимые параметры заполняет соответствующие поля. А уже в методе EXECUTE легко можно пользоваться данными, переданными ей при его создании.


 TYourThread = class(TTHread)
   private
     FFileName: string;
   protected
     procedure Execute; overrided;
   public
     constructor Create(CreateSuspennded: Boolean; const AFileName: string);
 end;
 
 ...
 
 constructor TYourThread.Create(CreateSuspennded: Boolean;
             const AFileName: string);
 begin
   inherited Create(CreateSuspennded);
   FFIleName := AFileName;
 end;
 
 procedure TYourThread.Execute;
 begin
   try
     ...
     if FFileName = ...
     ...
   except
     ...
   end;
 end;
 
 ...
 
 TYourForm = class(TForm)
 
 ...
 
 private
   YourThread: TYourThread;
   procedure LaunchYourThread(const AFileName: string);
   procedure YourTreadTerminate(Sender: TObject);
   ...
 end;
 
 ...
 
 procedure TYourForm.LaunchYourThread(
           const AFileName: string);
 begin
   YourThread := TYourThread.Create(True, AFileName);
   YourThread.Onterminate := YourTreadTerminate;
   YourThread.Resume
 end;
 
 ...
 
 procedure TYourForm.YourTreadTerminate(Sender: TObject);
 begin
   ...
 end;
 
 ...
 
 end.
 




Получение IP-адреса и маски для всех сетевых интерфейсов

Автор: Giannis Sampaziotis

Приходит девушка к программисту в гости, а тот:
- Чай, кофе, Интернет?

Существует множество методов получения IP адреса компьютера. Но данный пример представляет наиболее корректный способ получения всех адресов, сетевых масок, broadcast адресов и статусов для всех интерфейсов включая циклический 127.0.0.1 - требует WinSock 2.

Это завершённый Delphi компонент. Для его использования достаточно вызвать:


 EnumInterfaces(var s string): Boolean;
 

которая вернёт строку, разделённую CRLF и содержащую всё, нужную нам информацию.


 unit USock;
 
 interface
 
 uses
   Windows, Winsock;
 
 {
 
 Если Вы поместите строку результатов в wide TMEMO
 (в его свойство memo.lines.text)
 то никаких результатов не увидите.
 
 Тестировалось на Win98/ME/2K, 95 OSR 2 и NT service
 pack #3 , потому что используется WinSock 2 (WS2_32.DLL)
 
 }
 
 function EnumInterfaces(var sInt: string): Boolean;
 
 { функция WSAIOCtl импортируется из Winsock 2.0 - Winsock 2 доступен }
 { только в Win98/ME/2K и 95 OSR2, NT srv pack #3 }
 
 function WSAIoctl(s: TSocket; cmd: DWORD; lpInBuffer: PCHAR; dwInBufferLen:
   DWORD;
   lpOutBuffer: PCHAR; dwOutBufferLen: DWORD;
   lpdwOutBytesReturned: LPDWORD;
   lpOverLapped: POINTER;
   lpOverLappedRoutine: POINTER): Integer; stdcall; external 'WS2_32.DLL';
 
 { Константы взятые из заголовка C файлов }
 
 const
   SIO_GET_INTERFACE_LIST = $4004747F;
   IFF_UP = $00000001;
   IFF_BROADCAST = $00000002;
   IFF_LOOPBACK = $00000004;
   IFF_POINTTOPOINT = $00000008;
   IFF_MULTICAST = $00000010;
 
 type sockaddr_gen = packed record
   AddressIn: sockaddr_in;
   filler: packed array [0..7] of char;
 end;
 
 type INTERFACE_INFO = packed record
   iiFlags: u_long; // Флаги интерфейса
   iiAddress: sockaddr_gen; // Адрес интерфейса
   iiBroadcastAddress: sockaddr_gen; // Broadcast адрес
   iiNetmask: sockaddr_gen; // Маска подсети
 end;
 
 implementation
 
 {-------------------------------------------------------------------
 
 1. Открываем WINSOCK
 2. Создаём сокет
 3. Вызываем WSAIOCtl для доступа к сетевым интерфейсам
 4. Для каждого интерфейса, получаем IP, MASK, BROADCAST, статус
 5. Разделяем строку символом CRLF
 6. Конец :)
 
 --------------------------------------------------------------------}
 
 function EnumInterfaces(var sInt: string): Boolean;
 var
   s: TSocket;
   wsaD: WSADATA;
   NumInterfaces: Integer;
   BytesReturned, SetFlags: u_long;
   pAddrInet: SOCKADDR_IN;
   pAddrString: PCHAR;
   PtrA: pointer;
   Buffer: array[0..20] of INTERFACE_INFO;
   i: Integer;
 begin
   result := true; // Инициализируем переменную
   sInt := '';
 
   WSAStartup($0101, wsaD); // Запускаем WinSock
   // Здесь можно дабавить различные обработчики ошибки :)
 
   s := Socket(AF_INET, SOCK_STREAM, 0); // Открываем сокет
   if (s = INVALID_SOCKET) then
     exit;
 
   try // Вызываем WSAIoCtl
     PtrA := @bytesReturned;
     if (WSAIoCtl(s, SIO_GET_INTERFACE_LIST, nil, 0, @Buffer,
     1024, PtrA, nil, nil) <> SOCKET_ERROR) then
     begin // Если OK, то определяем количество существующих интерфейсов
 
       NumInterfaces := BytesReturned div SizeOf(INTERFACE_INFO);
 
       for i := 0 to NumInterfaces - 1 do // Для каждого интерфейса
       begin
         pAddrInet := Buffer[i].iiAddress.addressIn; // IP адрес
         pAddrString := inet_ntoa(pAddrInet.sin_addr);
         sInt := sInt + ' IP=' + pAddrString + ',';
         pAddrInet := Buffer[i].iiNetMask.addressIn; // Маска подсети
         pAddrString := inet_ntoa(pAddrInet.sin_addr);
         sInt := sInt + ' Mask=' + pAddrString + ',';
         pAddrInet := Buffer[i].iiBroadCastAddress.addressIn; // Broadcast адрес
         pAddrString := inet_ntoa(pAddrInet.sin_addr);
         sInt := sInt + ' Broadcast=' + pAddrString + ',';
 
         SetFlags := Buffer[i].iiFlags;
         if (SetFlags and IFF_UP) = IFF_UP then
           sInt := sInt + ' Interface UP,' // Статус интерфейса up/down
         else
           sInt := sInt + ' Interface DOWN,';
 
         if (SetFlags and IFF_BROADCAST) = IFF_BROADCAST then // Broadcasts
           sInt := sInt + ' Broadcasts supported,' // поддерживает или
         else // не поддерживается
           sInt := sInt + ' Broadcasts NOT supported,';
 
         if (SetFlags and IFF_LOOPBACK) = IFF_LOOPBACK then // Циклический или
           sInt := sInt + ' Loopback interface'
         else
           sInt := sInt + ' Network interface'; // нормальный
 
         sInt := sInt + #13#10; // CRLF между каждым интерфейсом
       end;
   end;
   except
   end;
   //
   // Закрываем сокеты
   //
   CloseSocket(s);
   WSACleanUp;
   result := false;
 end;
 
 end.
 




Определить состояние CapsLock


Озеро, тонет хакер:
- F1!!! F1!!! ... Тьфу-ты... Нelр!!! Нelр!!!


 procedure TForm1.Timer1Timer(Sender: TObject);
 begin
   if GetKeyState(VK_CAPITAL) and 1 = 0 then
     Form1.Caption := 'Caps lock не горит'
   else
     Form1.Caption := 'Caps lock горит';
 end;
 




Определить состояние CapsLock 2

Один программер отчитывает другого программера:
- У тебя что, руки под Ctrl-Alt-Del заточены?


 procedure AppOnIdle(Sender: TObject; var Done: Boolean);
 
 ...
 
 procedure TForm1.AppOnIdle(Sender: TObject; var Done: Boolean);
 begin
   CheckBox1.Checked := Odd(GetKeyState(VK_CAPITAL));
   CheckBox2.Checked := Odd(GetKeyState(VK_SHIFT));
   CheckBox3.Checked := Odd(GetKeyState(VK_NUMLOCK));
   CheckBox4.Checked := Odd(GetKeyState(VK_SCROLL));
   Done := False;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Application.OnIdle := AppOnIdle;
 end;
 




Определить состояние CapsLock 3


 function IsCapsLockOn: Boolean;
 begin
   Result := 0 <> (GetKeyState(VK_CAPITAL) and $01);
 end;
 




Получение списка DLL загруженных приложением

Автор: Simon Carter

Иногда бывает полезно знать какими DLL-ками пользуется Ваше приложение. Давайте посмотрим как это можно сделать в Win NT/2000:


 unit ModuleProcs;
 
 interface
 
 uses
   Windows, Classes;
 
 type
   TModuleArray = array [0..400] of HMODULE;
   TModuleOption = (moRemovePath, moIncludeHandle);
   TModuleOptions = set of TModuleOption;
 
 function GetLoadedDLLList(sl: TStrings;
   Options: TModuleOptions = [moRemovePath]): Boolean;
 
 implementation
 
 uses
   SysUtils;
 
 function GetLoadedDLLList(sl: TStrings;
   Options: TModuleOptions = [moRemovePath]): Boolean;
 type
   EnumModType = function (hProcess: Longint; lphModule: TModuleArray;
   cb: DWord; var lpcbNeeded: Longint): Boolean; stdcall;
 var
   psapilib: HModule;
   EnumProc: Pointer;
   ma: TModuleArray;
   I: Longint;
   FileName: array[0..MAX_PATH] of Char;
   S: string;
 begin
   Result := False;
 
   (* Данная функция запускается только для Widnows NT *)
   if Win32Platform <> VER_PLATFORM_WIN32_NT then
     Exit;
 
   psapilib := LoadLibrary('psapi.dll');
   if psapilib = 0 then
     Exit;
   try
     EnumProc := GetProcAddress(psapilib, 'EnumProcessModules');
     if not Assigned(EnumProc) then
       Exit;
     sl.Clear;
     FillChar(ma, SizeOF(TModuleArray), 0);
     if EnumModType(EnumProc)(GetCurrentProcess, ma, 400, I) then
     begin
       for I := 0 to 400 do
         if ma[i] <> 0 then
         begin
           FillChar(FileName, MAX_PATH, 0);
           GetModuleFileName(ma[i], FileName, MAX_PATH);
           if CompareText(ExtractFileExt(FileName), '.dll') = 0 then
           begin
             S := FileName;
             if moRemovePath in Options then
               S := ExtractFileName(S);
             if moIncludeHandle in Options then
               sl.AddObject(S, TObject(ma[I]))
             else
               sl.Add(S);
           end;
         end;
     end;
     Result := True;
   finally
     FreeLibrary(psapilib);
   end;
 end;
 
 end.
 

Для вызова приведённой функции надо сделать следующее:

Добавить listbox на форму (Listbox1)
Добавить кнопку на форму (Button1)

Обработчик события OnClick для кнопки будет выглядеть следующим образом:


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   GetLoadedDLLList(ListBox1.Items, [moIncludeHandle, moRemovePath]);
 end;
 




Как получить информацию о локальных настройках системы

Юзер: - Поставь-ка новые драйверы видеокарточки.
Windows: - А диск есть?
Юзер: - Есть.
Windows: - А что сказать надо?
Юзер: - Ok".
Windows: - Фиг тебе, а не Ok". Не могу найти необходимые файлы!
Юзер: - Так вот же они!
Windows: - Где?!
Юзер: - Да на диске!
Windows: - На каком?
Юзер: - На B:\.
Windows: - Нет такого диска.
Юзер: - А почему под DOS"ом есть?!
Windows: - Не мои проблемы.
Юзер: - А как же мне драйверы поставить?
Windows: - А зачем тебе драйверы? У тебя видеокарточки-то нет.
Юзер: - Не может быть!
Windows: - Точно тебе говорю.
Юзер: - А аудио есть?
Windows: - И аудио нет.
Юзер: - А что есть?
Windows: - Джойстик есть.
Юзер: - Отродясь не было...
Windows: - Мне виднее.
Юзер: - Надо же, а я его покупать собрался.
Windows: - Вот видишь! Что бы ты без меня делал?

Delphi имеет функцию GetLocaleInfo, которая позволяет получать различную информацию о локальных настройках, таких как системный язык, символ валюты, количество десятичных знаков и т.д.

Далее приведена функция, которая возвращает значение в зависимости от параметра "flag":


 function TForm1.GetLocaleInformation(Flag: Integer): string;
 var
   pcLCA: array [0..20] of Char;
 begin
   if GetLocaleInfo(LOCALE_SYSTEM_DEFAULT, Flag, pcLCA, 19) <= 0 then
     pcLCA[0] := #0;
   Result := pcLCA;
 end;
 

Пример использования функции:


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ShowMessage(GetLocaleInformation(LOCALE_SENGLANGUAGE));
 end;
 

"Flag" может содержать следующее значение (если посмотреть в Windows.pas):


 LOCALE_NOUSEROVERRIDE { do not use user overrides }
 LOCALE_USE_CP_ACP { use the system ACP }
 LOCALE_ILANGUAGE { language id }
 LOCALE_SLANGUAGE { localized name of language }
 LOCALE_SENGLANGUAGE { English name of language }
 LOCALE_SABBREVLANGNAME { abbreviated language name }
 LOCALE_SNATIVELANGNAME { native name of language }
 LOCALE_ICOUNTRY { country code }
 LOCALE_SCOUNTRY { localized name of country }
 LOCALE_SENGCOUNTRY { English name of country }
 LOCALE_SABBREVCTRYNAME { abbreviated country name }
 LOCALE_SNATIVECTRYNAME { native name of country }
 LOCALE_IDEFAULTLANGUAGE { default language id }
 LOCALE_IDEFAULTCOUNTRY { default country code }
 LOCALE_IDEFAULTCODEPAGE { default oem code page }
 LOCALE_IDEFAULTANSICODEPAGE { default ansi code page }
 LOCALE_IDEFAULTMACCODEPAGE { default mac code page }
 LOCALE_SLIST { list item separator }
 LOCALE_IMEASURE { 0 = metric, 1 = US }
 LOCALE_SDECIMAL { decimal separator }
 LOCALE_STHOUSAND { thousand separator }
 LOCALE_SGROUPING { digit grouping }
 LOCALE_IDIGITS { number of fractional digits }
 LOCALE_ILZERO { leading zeros for decimal }
 LOCALE_INEGNUMBER { negative number mode }
 LOCALE_SNATIVEDIGITS { native ascii 0-9 }
 LOCALE_SCURRENCY { local monetary symbol }
 LOCALE_SINTLSYMBOL { intl monetary symbol }
 LOCALE_SMONDECIMALSEP { monetary decimal separator }
 LOCALE_SMONTHOUSANDSEP { monetary thousand separator }
 LOCALE_SMONGROUPING { monetary grouping }
 LOCALE_ICURRDIGITS { # local monetary digits }
 LOCALE_IINTLCURRDIGITS { # intl monetary digits }
 LOCALE_ICURRENCY { positive currency mode }
 LOCALE_INEGCURR { negative currency mode }
 LOCALE_SDATE { date separator }
 LOCALE_STIME { time separator }
 LOCALE_SSHORTDATE { short date format string }
 LOCALE_SLONGDATE { long date format string }
 LOCALE_STIMEFORMAT { time format string }
 LOCALE_IDATE { short date format ordering }
 LOCALE_ILDATE { long date format ordering }
 LOCALE_ITIME { time format specifier }
 LOCALE_ITIMEMARKPOSN { time marker position }
 LOCALE_ICENTURY { century format specifier (short date) }
 LOCALE_ITLZERO { leading zeros in time field }
 LOCALE_IDAYLZERO { leading zeros in day field (short date) }
 LOCALE_IMONLZERO { leading zeros in month field (short date) }
 LOCALE_S1159 { AM designator }
 LOCALE_S2359 { PM designator }
 LOCALE_ICALENDARTYPE { type of calendar specifier }
 LOCALE_IOPTIONALCALENDAR { additional calendar types specifier }
 LOCALE_IFIRSTDAYOFWEEK { first day of week specifier }
 LOCALE_IFIRSTWEEKOFYEAR { first week of year specifier }
 LOCALE_SDAYNAME1 { long name for Monday }
 LOCALE_SDAYNAME2 { long name for Tuesday }
 LOCALE_SDAYNAME3 { long name for Wednesday }
 LOCALE_SDAYNAME4 { long name for Thursday }
 LOCALE_SDAYNAME5 { long name for Friday }
 LOCALE_SDAYNAME6 { long name for Saturday }
 LOCALE_SDAYNAME7 { long name for Sunday }
 LOCALE_SABBREVDAYNAME1 { abbreviated name for Monday }
 LOCALE_SABBREVDAYNAME2 { abbreviated name for Tuesday }
 LOCALE_SABBREVDAYNAME3 { abbreviated name for Wednesday }
 LOCALE_SABBREVDAYNAME4 { abbreviated name for Thursday }
 LOCALE_SABBREVDAYNAME5 { abbreviated name for Friday }
 LOCALE_SABBREVDAYNAME6 { abbreviated name for Saturday }
 LOCALE_SABBREVDAYNAME7 { abbreviated name for Sunday }
 LOCALE_SMONTHNAME1 { long name for January }
 LOCALE_SMONTHNAME2 { long name for February }
 LOCALE_SMONTHNAME3 { long name for March }
 LOCALE_SMONTHNAME4 { long name for April }
 LOCALE_SMONTHNAME5 { long name for May }
 LOCALE_SMONTHNAME6 { long name for June }
 LOCALE_SMONTHNAME7 { long name for July }
 LOCALE_SMONTHNAME8 { long name for August }
 LOCALE_SMONTHNAME9 { long name for September }
 LOCALE_SMONTHNAME10 { long name for October }
 LOCALE_SMONTHNAME11 { long name for November }
 LOCALE_SMONTHNAME12 { long name for December }
 LOCALE_SMONTHNAME13 { long name for 13th month (if exists) }
 LOCALE_SABBREVMONTHNAME1 { abbreviated name for January }
 LOCALE_SABBREVMONTHNAME2 { abbreviated name for February }
 LOCALE_SABBREVMONTHNAME3 { abbreviated name for March }
 LOCALE_SABBREVMONTHNAME4 { abbreviated name for April }
 LOCALE_SABBREVMONTHNAME5 { abbreviated name for May }
 LOCALE_SABBREVMONTHNAME6 { abbreviated name for June }
 LOCALE_SABBREVMONTHNAME7 { abbreviated name for July }
 LOCALE_SABBREVMONTHNAME8 { abbreviated name for August }
 LOCALE_SABBREVMONTHNAME9 { abbreviated name for September }
 LOCALE_SABBREVMONTHNAME10 { abbreviated name for October }
 LOCALE_SABBREVMONTHNAME11 { abbreviated name for November }
 LOCALE_SABBREVMONTHNAME12 { abbreviated name for December }
 LOCALE_SABBREVMONTHNAME13 { abbreviated name for 13th month (if exists) }
 LOCALE_SPOSITIVESIGN { positive sign }
 LOCALE_SNEGATIVESIGN { negative sign }
 LOCALE_IPOSSIGNPOSN { positive sign position }
 LOCALE_INEGSIGNPOSN { negative sign position }
 LOCALE_IPOSSYMPRECEDES { mon sym precedes pos amt }
 LOCALE_IPOSSEPBYSPACE { mon sym sep by space from pos amt }
 LOCALE_INEGSYMPRECEDES { mon sym precedes neg amt }
 LOCALE_INEGSEPBYSPACE { mon sym sep by space from neg amt }
 LOCALE_FONTSIGNATURE { font signature }
 LOCALE_SISO639LANGNAME { ISO abbreviated language name }
 LOCALE_SISO3166CTRYNAME { ISO abbreviated country name }
 




Как узнать адрес LPT-порта

Эта функция работает в Win95 и Win98.


 function GetPortAddress(PortNo: integer): word; assembler; stdcall;
 asm
   push es
   push ebx
   mov ebx, PortNo
   shl ebx,1
   mov ax,40h // Dos segment adress
   mov es,ax
   mov ax,ES:[ebx+6] // get port adress in 16Bit way :)
   pop ebx
   pop es
 end;
 




Получение значения Memo-поля с помощью Query

Получение Memo-значения в область Edit без использования Memo-поля.

  • Разместите на вашей форме объект Query (Query1)
  • Разместите на вашей форме объект Edit (Edit1)
  • Разместите на вашей форме объект Button (Button1)
  • Дважды щелкните на Query и добавьте поле Memo. (Biolife.db использует текстовое поле)
  • Установите свойство Query1 SQL следующим образом: Select * from Biolife
  • Установите свойство Query1 Active в True
  • Добавьте следующий код в обработчик события кнопки Button1 OnClick:

 procedure TForm1.Button1Click(Sender: TObject);
 var
   bs: TBlobStream;
   p: array[0..50] of char;
 begin
   FillChar(p, SizeOf(p), #0);
   bs := TBlobStream.Create(Query1Notes, bmRead);
   try
     bs.Read(p, 50);
   finally
     bs.Free;
   end;
   Edit1.Text := StrPas(p);
 end;
 




Получить список установленных модемов в Windows

У диалапера спрашивают:
- А что ты тестируешь, качество связи с новым провайдером?
- Нет, свои нервы... сколько они еще смогут выдержать этот коннект!!!


 unit PortInfo;
 
 interface
 
 uses
   Windows, SysUtils, Classes, Registry;
 
   function EnumModems: TStrings;
 
 implementation
 
 function EnumModems : TStrings;
 var
   R : TRegistry;
   s : ShortString;
   N : TStringList;
   i : integer;
   j : integer;
 begin
   Result:= TStringList.Create;
   R:= TRegistry.Create;
   try
     with R do
     begin
       RootKey:= HKEY_LOCAL_MACHINE;
       if OpenKey('\System\CurrentControlSet\Services\Class\Modem', False) then
         if HasSubKeys then
         begin
           N:= TStringList.Create;
           try
             GetKeyNames(N);
             for i:=0 to N.Count - 1 do
             begin
               closekey; { + }
               openkey('\System\CurrentControlSet\Services\Class\Modem', false);
               OpenKey(N[i], False);
               s:= ReadString('AttachedTo');
               for j:=1 to 4 do
                 if Pos(Chr(j+Ord('0')), s) > 0 then
                   Break;
               Result.AddObject(ReadString('DriverDesc'),TObject(j));
               CloseKey;
             end;
           finally
             N.Free;
           end;
         end;
     end;
   finally
     R.Free;
   end;
 end;
 
 end.
 




Получить список установленных модемов в винде


 function EnumModems: TStrings;
 var
   R: TRegistry;
   s: ShortString;
   N: TStringList;
   i, j: integer;
 begin
   Result := TStringList.Create;
   R := TRegistry.Create;
   try
     with R do
     begin
       RootKey := HKEY_LOCAL_MACHINE;
       if OpenKey('\System\CurrentControlSet\Services\Class\Modem', False) then
         if HasSubKeys then
         begin
           N := TStringList.Create;
           try
             GetKeyNames(N);
             for i := 0 to N.Count - 1 do
             begin
               CloseKey;
               OpenKey(N[i], False);
               s := ReadString('AttachedTo');
               for j := 1 to 4 do
                 if Pos(Chr(j + Ord('0')), s) > 0 then
                   Break;
               Result.AddObject(ReadString('DriverDesc'), TObject(j));
               CloseKey;
             end;
           finally
             N.Free;
           end;
         end;
     end;
   finally
     R.Free;
   end;
 end;
 




Как определить состояние модема под Win32


Пришел Новый Русский в компьютерный магазин и спрашивает:
- Братан, кто у вас тут самый крутой? Процессор?
- Нет.
- А может это...
Материнская плата??
- Нет.
- Хммм... Блин... А кто же???
- Модем.
- Он наверно такой умный???
- Да нет.
- А чеее тогда?
- У него такие связи!


 procedure TForm1.Button1Click(Sender: TObject);
 var
   CommPort : string;
   hCommFile : THandle;
   ModemStat : DWord;
 begin
   CommPort := 'COM2';
 
   {Open the comm port}
   hCommFile := CreateFile(PChar(CommPort), GENERIC_READ, 0, nil,
   OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
   if hCommFile = INVALID_HANDLE_VALUE then
   begin
     ShowMessage('Unable to open '+ CommPort);
     exit;
   end;
 
   {Get the Modem Status}
   if GetCommModemStatus(hCommFile, ModemStat) <> false then
   begin
     if ModemStat and MS_CTS_ON <> 0 then
       ShowMessage('The CTS (clear-to-send) is on.');
     if ModemStat and MS_DSR_ON <> 0 then
       ShowMessage('The DSR (data-set-ready) is on.');
     if ModemStat and MS_RING_ON <> 0 then
       ShowMessage('The ring indicator is on.');
     if ModemStat and MS_RLSD_ON <> 0 then
       ShowMessage('The RLSD (receive-line-signal-detect) is on.');
   end;
 
   {Close the comm port}
   CloseHandle(hCommFile);
 end;
 




Получение имени модуля

Валентин Озеров


 procedure TForm1.Button1Click(Sender: TObject);
 var
   szFileName : array[0..49] of char;
   szModuleName : array[0..19] of char;
   iSize : integer;
 begin
   StrPCopy(szModuleName, 'NameOfModule');
   iSize := GetModuleFileName(GetModuleHandle(szModuleName),szFileName,
     SizeOf(szFileName));
   if iSize > 0 then
     ShowMessage('Имя модуля с полным путем: ' + StrPas(szFileName))
   else
     ShowMessage('Имя модуля не встречено');
 end;
 

Андрей Иванов


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ShowMessage(ParamStr(0));
 end;
 

Степанова Павла


 // Включить в Uses SysUtils
 
 procedure TMainForm.Button2Click(Sender: TObject);
 var
   AppDirectory, AppPathName: string;
 begin
   AppPathName := Application.ExeName;
   AppDirectory := ExtractFilePath(AppPathName);
   messageDlg('Имя программы '+ AppPathName+#13+
     'Имя каталога программы '+ AppDirectory
     ,mtInformation,[mbOK],0);
 end;
 




Определение своего IP адреса

Из воспоминай системного администратора. "Все что я помню об этой девушке, это ее IP-адрес..."


 function my_ip_address: longint;
 const
   bufsize = 255;
 var
   buf: pointer;
   RemoteHost: PHostEnt; (* Не освобождайте это! *)
 begin
   buf := nil;
   try
     getmem(buf, bufsize);
     winsock.gethostname(buf, bufsize); (* это может работать и без сети *)
     RemoteHost := Winsock.GetHostByName(buf);
     if RemoteHost = nil then
       my_ip_address := winsock.htonl($07000001) (* 127.0.0.1 *)
     else
       my_ip_address := longint(pointer(RemoteHost^.h_addr_list^)^);
   finally
     if buf <> nil then
       freemem(buf, bufsize);
   end;
   result := winsock.ntohl(result);
 end;
 

Вначале возвращается локальный сетевой адрес компьютера, а затем, если он не равен 127.0.0.1, стандартный IP адрес.

Единственное, что вам необходимо, это наличие winsock.dcu/winsock.pas, так как это не включается в поставку Delphi 1.; необходимый мне код я взял из tcpip component pack (просто вырезал его оттуда).




Получить список доменов

Бог есть. Он просто администрит другой домен...

Переменная List заполняется списком доменов. Функция возвращает код ошибки обращения к сети.


 function FillNetLevel(xxx: PNetResource; list: TStrings): Word;
 type
   PNRArr = ^TNRArr;
   TNRArr = array[0..59] of TNetResource;
 var
   x: PNRArr;
   tnr: TNetResource;
   I: integer;
   EntrReq,
     SizeReq,
     twx: Integer;
   WSName: string;
 begin
   Result := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY,
     RESOURCEUSAGE_CONTAINER, xxx, twx);
   if Result = ERROR_NO_NETWORK then
     Exit;
   if Result = NO_ERROR then
   begin
     New(x);
     EntrReq := 1;
     SizeReq := SizeOf(TNetResource) * 59;
     while (twx < > 0) and
       (WNetEnumResource(twx, EntrReq, x, SizeReq) <> ERROR_NO_MORE_ITEMS) do
     begin
       for i := 0 to EntrReq - 1 do
       begin
         Move(x^[i], tnr, SizeOf(tnr));
         case tnr.dwDisplayType of
           RESOURCEDISPLAYTYPE_DOMAIN:
             begin
               if tnr.lpRemoteName < > '' then
                 WSName := tnr.lpRemoteName
               else
                 WSName := tnr.lpComment;
               list.Add(WSName);
             end;
         else
           FillNetLevel(@tnr, list);
         end;
       end;
     end;
     Dispose(x);
     WNetCloseEnum(twx);
   end;
 end;
 




Получение сетевого имени пользователя

Защита от "дурака" спасает только от неизобретательного дурака.

Вы можете попробовать этот код. Я без проблем использовал его под Netware LAN в течение долгого времени. Работа программы зависит от наличия NWCALLS.DLL на машине пользователя, но если он использовал сеть хоть раз, данная библиотека должна присутствовать на его машине.


 unit GetLogin;
 
 {
 Данный модуль инкапсулирует несколько внешних
 функций библиотеки NWCALLS.DLL
 Создан на основе кода Григория Трубецкого
 Модуль содержит функции, возвращающие Netware User ID
 и полное имя пользователя.
 }
 
 interface
 
 uses
   SysUtils, Messages, Dialogs;
 function GetUserLogin: string;
 function GetUserFullName(SomeUser: string): string;
 
 implementation
 
 type
   NWTimeStamp = record
     Year: byte;
     Month: byte;
     Day: byte;
     Hour: byte;
     Minute: byte;
     Second: byte;
     DayOfWeek: byte;
   end;
 
   {Netware API - требуется NWCALLS.DLL}
 
 function NWGetDefaultConnectionID(var Connection: word): word;
   far; external 'NWCALLS';
 
 function NWGetConnectionNumber(Connection: word; var ConnectionNumber:
   word): word;
 
 far; external 'NWCALLS';
 
 function NWGetConnectionInformation(Connection: word;
   ConnectionNumber: word;
   ObjectName: pchar;
   var ObjectType: word;
   var ObjectID: word;
   var LoginTime: NWTimeStamp): word;
   far; external 'NWCALLS';
 
 function NWReadPropertyValue(Connection: word;
   ObjectName: pChar;
   ObjectType: word;
   PropertyName: pChar;
   DataSetIndex: byte;
   DataBuffer: pChar;
   var More: byte;
   var Flags: byte): word;
   far; external 'NWCALLS';
 { конец секции работы с Netware API }
 
 function GetUserLogin: string;
 var
 
   ConnectionID: word;
   ConnectionNumber: word;
   RC: word;
   Name: array[0..50] of Char;
   ObjectType: word;
   ObjectID: word;
   LoginTime: NWTimeStamp;
 begin
 
   RC := NWGetDefaultConnectionID(ConnectionID);
   RC := NWGetConnectionNumber(ConnectionID, ConnectionNumber);
   RC := NWGetConnectionInformation(ConnectionID,
     ConnectionNumber,
     Name,
     ObjectType,
     ObjectID,
     LoginTime);
 
   Result := StrPas(Name);
 end;
 
 function GetUserFullName(SomeUser: string): string;
 {Реально имя пользователя является свойством 'IDENTIFICATON'.
 Вы должны вызывать NWReadPropertyValue с параметрами (между прочим) вашего ConnectionID,
 имени объекта (такое же, как и логин пользователя, сетевое имя которого мы пытаемся узнать)
 и свойство name, которое нам необходимо получить, в нашем случае 'IDENTIFICATION'
 (это и есть искомая величина - полное имя пользователя).}
 
 var
 
   ConnectionID: word;
   RC: word;
   Name: array[0..50] of Char;
   ObjectType: word;
   PropName: array[0..14] of Char;
   DataSetIndex: byte;
   FullName: array[0..127] of Char;
   More: byte;
   Flags: byte;
 begin
 
   RC := NWGetDefaultConnectionID(ConnectionID);
   ObjectType := 256; {пользователь}
   StrPCopy(PropName, 'IDENTIFICATION');
   DataSetIndex := 1;
   StrPCopy(Name, SomeUser);
   RC := NWReadPropertyValue(ConnectionID,
     Name,
     ObjectType,
     PropName,
     DataSetIndex,
     FullName,
     More,
     Flags);
   if RC = 35324 then
     MessageDlg('Пользователь ' + SomeUser + ' на этом сервере не обнаружен!',
       mtError, [mbOK], 0);
   Result := StrPas(FullName);
 end;
 
 end.
 




Как получить число и список всех компонентов, расположенных на TNoteBook

Warp 4 спpашивает у хозяина:
- Хозяяяин, а у меня в pоду была DesqView?
- Hет, не было.
- Хозяяяин, а Windows 3.1 у меня в pоду не было?
- Hет, конечно не было.
- Хозяяяяин, а почему же тогда я такой тоpмозноооой?


 procedure TForm1.Button1Click(Sender: TObject);
 var
   n, p: integer;
 begin
   ListBox1.Clear;
   with Notebook1 do
     for n := 0 to ControlCount - 1 do
       with TPage(Controls[n]) do
       begin
         ListBox1.Items.Add('Notebook Page: ' + TPage(Notebook1.Controls[n]).Caption);
         for p := 0 to ControlCount - 1 do
           ListBox1.Items.Add(Controls[p].name);
         ListBox1.Items.Add(EmptyStr);
       end;
 end;
 




Как узнать имя домена в Windows?


- Мы с другом поставили Windows' 2000 и тормознули крутейший PentiumIII-600!


 function GetNTDomainName: string;
 var
   hReg: TRegistry;
 begin
   hReg := TRegistry.Create;
   hReg.RootKey := HKEY_LOCAL_MACHINE;
   hReg.OpenKey('SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon', false );
   Result := hReg.ReadString( 'DefaultDomainName' );
   hReg.CloseKey;
   hReg.Destroy;
 end;
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS