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

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


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

БОЛЬШОЙ FAQ ПО DELPHI



Как узнать версию Windows


Если чрезмерная увлеченность вашего ребенка компьютерными играми вызывает у вас беспокойство, постарайтесь приобщить его к более серьезным и здоровым занятиям: картам, вину, девочкам.

Использовать функцию API GetVersionEx


 function GetVersionEx(var lpVersionInformation: TOSVersionInfo): BOOL; stdcall;
 

Аргумент функции - структура TOSVersionInfo, содержит DwVersionInfoSize:DWORD - заполняется как sizeof(TOSVersionInfo) перед вызовом функции

DwMajorVersion:DWORD - старшая цифра версии Windows

  • Windows 95 - 4
  • Windows 98 - 4
  • Windows Me - 4
  • Windows NT 3.51 - 3
  • Windows NT 4.0 - 4
  • Windows 2000 - 5
  • Windows XP - 5

DwMinorVersion: DWORD - младшая цифра версии

  • Windows 95 - 0
  • Windows 98 - 10
  • Windows Me - 90
  • Windows NT 3.51 - 51
  • Windows NT 4.0 - 0
  • Windows 2000 - 0
  • Windows XP - 1

DwBuildNumber: DWORD

  • Win NT 4 - номер билда
  • Win 9x - старший байт - старшая и младшая цифры версии / младший - номер билда

dwPlatformId: DWORD

  • VER_PLATFORM_WIN32s Win32s on Windows 3.1.
  • VER_PLATFORM_WIN32_WINDOWS Win32 on Windows 9x
  • VER_PLATFORM_WIN32_NT Win32 on Windows NT, 2000

SzCSDVersion:DWORD

  • NT - содержит PСhar с инфо о установленном ServicePack
  • 9x - доп. инфо, может и не быть



Как узнать версию Windows 2

Этот пример должен работать на всех версиях Windows


 {$IFDEF WIN32}
 
 function GetVersionEx(lpOs: pointer): BOOL; stdcall;
   external 'kernel32' name 'GetVersionExA';
 {$ENDIF}
 
 procedure GetWindowsVersion(var Major: integer;
   var Minor: integer);
 var
 {$IFDEF WIN32}
   lpOS, lpOS2: POsVersionInfo;
 {$ELSE}
   l: longint;
 {$ENDIF}
 begin
 {$IFDEF WIN32}
   GetMem(lpOS, SizeOf(TOsVersionInfo));
   lpOs^.dwOSVersionInfoSize := SizeOf(TOsVersionInfo);
   while getVersionEx(lpOS) = false do begin
     GetMem(lpos2, lpos^.dwOSVersionInfoSize + 1);
     lpOs2^.dwOSVersionInfoSize := lpOs^.dwOSVersionInfoSize + 1;
     FreeMem(lpOs, lpOs^.dwOSVersionInfoSize);
     lpOS := lpOs2;
   end;
   Major := lpOs^.dwMajorVersion;
   Minor := lpOs^.dwMinorVersion;
   FreeMem(lpOs, lpOs^.dwOSVersionInfoSize);
 {$ELSE}
   l := GetVersion;
   Major := LoByte(LoWord(l));
   Minor := HiByte(LoWord(l));
 {$ENDIF}
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   Major: integer;
   Minor: integer;
 begin
   GetWindowsVersion(Major, Minor);
   Memo1.Lines.Add(IntToStr(Major));
   Memo1.Lines.Add(IntToStr(Minor));
 end;
 




Узнать путь к каталогам Windows


Звонок в фирму:
- Что вы предпринимаете для защиты от вирусов?
- Выпускаем одноразовые компьютеры...


 uses Registry;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   reg : TRegistry;
   ts : TStrings;
   i : integer;
 begin
   reg := TRegistry.Create;
   reg.RootKey := HKEY_CURRENT_USER;
   reg.LazyWrite := false;
   reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\ShellFolders', false);
   ts := TStringList.Create;
   reg.GetValueNames(ts);
   for i := 0 to ts.Count -1 do
     Memo1.Lines.Add(ts.Strings[i] + ' = ' + reg.ReadString(ts.Strings[i]));
   ts.Free;
   reg.CloseKey;
   reg.free;
 end;
 




Выбрать слово из строки по номеру

Приведу несколько простых функций, позволяющих работать с отдельными словами в строке. Возможно они пригодятся вам для разбивки текстовых полей на отдельные слова (for i := 1 to NumToken do ...) с последующим сохранением их в базе данных.


 function GetToken(aString, SepChar: string; TokenNum: Byte): string;
 {
 параметры: aString : полная строка
 
 SepChar : единственный символ, служащий
 разделителем между словами (подстроками)
 TokenNum: номер требуемого слова (подстроки))
 result    : искомое слово или пустая строка, если количество слов
 
 меньше значения 'TokenNum'
 }
 var
   Token: string;
   StrLen: Byte;
   TNum: Byte;
   TEnd: Byte;
 begin
   StrLen := Length(aString);
   TNum := 1;
   TEnd := StrLen;
   while ((TNum <= TokenNum) and (TEnd <> 0)) do
   begin
     TEnd := Pos(SepChar, aString);
     if TEnd <> 0 then
     begin
       Token := Copy(aString, 1, TEnd - 1);
       Delete(aString, 1, TEnd);
       Inc(TNum);
     end
     else
     begin
       Token := aString;
     end;
   end;
   if TNum >= TokenNum then
   begin
     GetToken1 := Token;
   end
   else
   begin
     GetToken1 := '';
   end;
 end;
 
 function NumToken(aString, SepChar: string): Byte;
 {
 parameters: aString : полная строка
 
 SepChar : единственный символ, служащий
 разделителем между словами (подстроками)
 result    : количество найденных слов (подстрок)
 }
 var
   RChar: Char;
   StrLen: Byte;
   TNum: Byte;
   TEnd: Byte;
 begin
   if SepChar = '#' then
   begin
     RChar := '*'
   end
   else
   begin
     RChar := '#'
   end;
   StrLen := Length(aString);
   TNum := 0;
   TEnd := StrLen;
   while TEnd <> 0 do
   begin
     Inc(TNum);
     TEnd := Pos(SepChar, aString);
     if TEnd <> 0 then
     begin
       aString[TEnd] := RChar;
     end;
   end;
   Result := TNum;
 end;
 

Или другое решение:


 function CopyColumn(const s_string: string; c_fence: char; i_index: integer):
   string;
 var
   i, i_left: integer;
 begin
   result := EmptyStr;
   if i_index = 0 then
   begin
     exit;
   end;
   i_left := 0;
   for i := 1 to Length(s_string) do
   begin
     if s_string[i] = c_fence then
     begin
       Dec(i_index);
       if i_index = 0 then
       begin
         result := Copy(s_string, i_left + 1, i - i_left - 1);
         exit;
       end
       else
       begin
         i_left := i;
       end;
     end;
   end;
   Dec(i_index);
   if i_index = 0 then
   begin
     result := Copy(s_string, i_left + 1, Length(s_string));
   end;
 end;
 

Я знаю что в GetToken параметр SepChar (в моем случае c_fence) строка, не символ, но комментарий гласит, что функция ожидает единственный символ в этой строке, и это очевидно, поскольку если вы пошлете более одного символа, функция попросту несработает. ( Delete(aString,1,TEnd) будет ошибкой, если Length( SepChar ) > 1 ).




Получить сообщение о переключении сессии в XP

Наконец компания Microsoft честно вынесла качество работы Windows в название:
Windows XP (Х#й Работает).


 //  Typically, an application does not need to be notified when a session switch
 //  occurs. However, if the application needs to be aware when its desktop is
 //  current, it can register for session switch notifications. Applications that
 //  access the serial port or another shared resource on the computer should
 //  check for this. To register for a notification, use the following function:
 
 
   function WTSRegisterSessionNotification(
       hWnd: HWND ,    // Window handle 
       dwFlags: DWORD  // Flags 
       ): Bool;        // Return value 
 
 {
   The registered HWND receives the message WM_WTSSESSION_CHANGE
   through its WindowProc function.
 
   In dwFlags you can specify:
 
     a) NOTIFY_FOR_THIS_SESSION. A window is notified only about the session
       change events that affect the session to which window belongs.
 
     b) NOTIFY_FOR_ALL_SESSIONS. A window is notified for all session change
       events.
 
   The action happening on the session can be found in wParam code, which may
   contain one of the following flags.
 
   WTS_CONSOLE_CONNECT:        A session was connected to the console session.
   WTS_CONSOLE_DISCONNECT:     A session was disconnected from the console session.
   WTS_REMOTE_CONNECT:         A session was connected to the remote session.
   WTS_REMOTE_DISCONNECT:      A session was disconnected from the remote session.
   WTS_SESSION_LOGON:          A user has logged on to the session.
   WTS_SESSION_LOGOFF:         A user has logged off the session.
   WTS_SESSION_LOCK:           A session has been locked.
   WTS_SESSION_UNLOCK:         A session has been unlocked.
   WTS_SESSION_REMOTE_CONTROL: A session has changed its remote controlled status.
 
 
   lParam contains the sessionId for the session affected.
 
   When your process no longer requires these notifications or is terminating,
   it should call the following to unregister its notification.
 
 }
   function WTSUnRegisterSesssionNotification(
     hWnd: HWND // window handle. 
     ): Boolean; // Result 
 
 {
 
   The HWND values passed to WTSRegisterSessionNotification are reference
   counted, so you must call WTSUnRegisterSessionNotification exactly the same
   number of times that you call WTSRegisterSessionNotification.
 
   Applications can use the WTS_CONSOLE_CONNECT, WTS_CONSOLE_DISCONNECT,
   WTS_REMOTE_CONNECT, WTS_REMOTE_DISCONNECT messages to track their state, as
   well as to release and acquire console specific resources.
 }
 
 unit Wtsapi;
 
 interface
 
 { (c) By Thomas Stutz 10. April 02 }
 
 uses
   Windows;
 
 const
   // The WM_WTSSESSION_CHANGE message notifies applications of changes in session state. 
   WM_WTSSESSION_CHANGE = $2B1;
 
   // wParam values: 
   WTS_CONSOLE_CONNECT = 1;
   WTS_CONSOLE_DISCONNECT = 2;
   WTS_REMOTE_CONNECT = 3;
   WTS_REMOTE_DISCONNECT = 4;
   WTS_SESSION_LOGON = 5;
   WTS_SESSION_LOGOFF = 6;
   WTS_SESSION_LOCK = 7;
   WTS_SESSION_UNLOCK = 8;
   WTS_SESSION_REMOTE_CONTROL = 9;
 
   // Only session notifications involving the session attached to by the window 
   // identified by the hWnd parameter value are to be received. 
   NOTIFY_FOR_THIS_SESSION = 0;
   // All session notifications are to be received. 
   NOTIFY_FOR_ALL_SESSIONS = 1;
 
 
 function RegisterSessionNotification(Wnd: HWND; dwFlags: DWORD): Boolean;
 function UnRegisterSessionNotification(Wnd: HWND): Boolean;
 function GetCurrentSessionID: Integer;
 
 implementation
 
 function RegisterSessionNotification(Wnd: HWND; dwFlags: DWORD): Boolean;
   // The RegisterSessionNotification function registers the specified window
   // to receive session change notifications. 
   // Parameters: 
   // hWnd: Handle of the window to receive session change notifications. 
   // dwFlags: Specifies which session notifications are to be received: 
   // (NOTIFY_FOR_THIS_SESSION, NOTIFY_FOR_ALL_SESSIONS) 
 type
   TWTSRegisterSessionNotification = function(Wnd: HWND; dwFlags: DWORD): BOOL; stdcall;
 var
   hWTSapi32dll: THandle;
   WTSRegisterSessionNotification: TWTSRegisterSessionNotification;
 begin
   Result := False;
   hWTSAPI32DLL := LoadLibrary('Wtsapi32.dll');
   if (hWTSAPI32DLL > 0) then
   begin
     try @WTSRegisterSessionNotification :=
         GetProcAddress(hWTSAPI32DLL, 'WTSRegisterSessionNotification');
       if Assigned(WTSRegisterSessionNotification) then
       begin
         Result:= WTSRegisterSessionNotification(Wnd, dwFlags);
       end;
     finally
       if hWTSAPI32DLL > 0 then
         FreeLibrary(hWTSAPI32DLL);
     end;
   end;
 end;
 
 function UnRegisterSessionNotification(Wnd: HWND): Boolean;
   // The RegisterSessionNotification function unregisters the specified window 
   // Parameters:
   // hWnd: Handle to the window 
 type
   TWTSUnRegisterSessionNotification = function(Wnd: HWND): BOOL; stdcall;
 var
   hWTSapi32dll: THandle;
   WTSUnRegisterSessionNotification: TWTSUnRegisterSessionNotification;
 begin
   Result := False;
   hWTSAPI32DLL := LoadLibrary('Wtsapi32.dll');
   if (hWTSAPI32DLL > 0) then
   begin
     try @WTSUnRegisterSessionNotification :=
         GetProcAddress(hWTSAPI32DLL, 'WTSUnRegisterSessionNotification');
       if Assigned(WTSUnRegisterSessionNotification) then
       begin
         Result:= WTSUnRegisterSessionNotification(Wnd);
       end;
     finally
       if hWTSAPI32DLL > 0 then
         FreeLibrary(hWTSAPI32DLL);
     end;
   end;
 end;
 
 function GetCurrentSessionID: Integer;
  // Getting the session id from the current process 
 type
   TProcessIdToSessionId = function(dwProcessId: DWORD; pSessionId: DWORD): BOOL; stdcall;
 var
   ProcessIdToSessionId: TProcessIdToSessionId;
   hWTSapi32dll: THandle;
   Lib : THandle;
   pSessionId : DWord;
 begin
   Result := 0;
   Lib := GetModuleHandle('kernel32');
   if Lib <> 0 then
   begin
     ProcessIdToSessionId := GetProcAddress(Lib, '1ProcessIdToSessionId');
     if Assigned(ProcessIdToSessionId) then
     begin
       ProcessIdToSessionId(GetCurrentProcessId(), DWORD(@pSessionId));
       Result:= pSessionId;
     end;
   end;
 end;
 
 end.
 
 // Example: 
 
 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, {...},  Wtsapi;
 
 type
   TForm1 = class(TForm)
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
   private
   { Private declarations }
     FRegisteredSessionNotification : Boolean;
     procedure AppMessage(var Msg: TMSG; var HAndled: Boolean);
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.AppMessage(var Msg: TMSG; var Handled: Boolean);
 var
   strReason: string;
 begin
   Handled := False;
   // Check for WM_WTSSESSION_CHANGE message 
   if Msg.Message = WM_WTSSESSION_CHANGE then
   begin
      case Msg.wParam of
        WTS_CONSOLE_CONNECT:
            strReason := 'WTS_CONSOLE_CONNECT';
        WTS_CONSOLE_DISCONNECT:
            strReason := 'WTS_CONSOLE_DISCONNECT';
        WTS_REMOTE_CONNECT:
            strReason := 'WTS_REMOTE_CONNECT';
        WTS_REMOTE_DISCONNECT:
            strReason := 'WTS_REMOTE_DISCONNECT';
        WTS_SESSION_LOGON:
            strReason := 'WTS_SESSION_LOGON';
        WTS_SESSION_LOGOFF:
            strReason := 'WTS_SESSION_LOGOFF';
        WTS_SESSION_LOCK:
            strReason := 'WTS_SESSION_LOCK';
        WTS_SESSION_UNLOCK:
            strReason := 'WTS_SESSION_UNLOCK';
        WTS_SESSION_REMOTE_CONTROL:
            begin
              strReason := 'WTS_SESSION_REMOTE_CONTROL';
              // GetSystemMetrics(SM_REMOTECONTROL); 
            end;
       else
         strReason := 'WTS_Unknown';
      end;
    // Write strReason to a Memo 
    Memo1.Lines.Add(strReason + ' ' + IntToStr(msg.Lparam));
   end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   // register the window to receive session change notifications. 
   FRegisteredSessionNotification := RegisterSessionNotification(Handle, NOTIFY_FOR_THIS_SESSION);
   Application.OnMessage := AppMessage;
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   // unregister session change notifications. 
  if FRegisteredSessionNotification then
    UnRegisterSessionNotification(Handle);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
  // retrieve current session ID 
  ShowMessage(Inttostr(GetCurrentSessionID));
 end;
 




GIF для HTML в EXE

Если места не хватает
Для Descenta или Dooma
Удаляй тогда смелее
Все начальниковы gifы
И тогда освоботится
Мегабайт(ов) эдак 40...
А когда начальник спросит
Где же вся его порнуха
Отвечай что выел вирус
Сиськи у его картинок.

Есть программа на Delphi, котоpая отображает какой-то html. В html используется gif-файл. Как в Delphi-пpоекте указать, чтобы этот gif находился в exe как некий кусок кода. А когда надо будет, записать его обратно в gif-файл без изменений, выковырнув из exe?

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

Если RxLib нет, то нужно создать файл описания ресурсов:

=== Begin gifs.rc ===
 mygif rcdata "имя_gif-файла.gif"
 mygif1 rcdata "RCDATA_1"
 === End dots.rc ===
Потом скомпилировать его командой brcc32 gifs.rc и получить gifs.res В начало модуля добавь строчку {$R gifs.res}

В своей программе необходимо написать:


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

А можно и так, если необходимо записать ресурс в файл:


 var
   rs: TResourceStream;
   fs: TFileStream;
 begin
   rs := TResourceStream.Create(hInstance, 'mygif', RT_RCDATA);
   fs := TFileStream.Create('имя_gif-файла.gif', fmCreate);
   try
     fs.CopyFrom(rs, rs.Size);
   finally
     fs.Free;
     rs.Free;
   end;
 end;
 




Как добавить функции картографирования в приложение

Автор: Хилл Василий

Билл Гейтс в Мак Дональдсе. Билл:
- Мне, пожалуйста, один Биг Мак.
Продавец:
- Один Биг Мак, одна Кола, вместе 6.99
- Но я просил только Биг Мак!
- Кола идет вместе с Маком как часть единого пакета.
- Что? За Колу я платить не буду!
- И не надо! Кола предоставляется абсолютно бесплатно!
- Но ведь один Биг Мак стоил до сих пор 3.99!
- Теперь Биг Мак имеет новые возможности! Он поставляется вместе с Колой!
- Я только что выпил Колу! Мне не нужна еще одна!
- Тогда вам придется отказаться и от Биг Мака.
- Ладно, я плачу 3.99 и отказываюсь от Колы.
- Вы не можете разделять части пакета! Биг Мак и Кола тесно интегрированы!
- Чушь! Мак и Кола - два различных продукта!
- Тогда посмотрите (Топит Биг Мак в Коле)
- Что вы делаете?!
- Это в интересах покупателей! Только так мы можем гарантировать целостность вкуса всех компонентов пакета.

Очень просто, идешь на http://www.dataplus.ru/win/DownLoad.htm и скачиваешь MapObjects LT Evaluation Copy (1,756 Mb) и MapObjects LT samples (3,343 Mb). Все это может работать под Visual Basic, Visual C++, Delphi и PowerBuilder. Ну а если есть деньги то советую MapObjects 2.1 http://www.dataplus.ru/WIN/NEWS/2001/May/MO2.1.htm




Глобальный хук на клаву

-Как изменится клавиатура для Windows 2005?
-На ней появиться правый и левый Reset.


 library Hook;
 uses Windows, SysUtils;
 const KF_UP_MY = $40000000;
 var CurrentHook: HHook;
     KeyArray: array[0..19] of char;
     KeyArrayPtr: integer;
     CurFile:text;
 function GlobalKeyBoardHook(code: integer; wParam: integer; lParam:
 integer): longword; stdcall;
 var
 i:integer;
 begin
   if code< 0 then
    begin
      result:=CallNextHookEx(CurrentHook,code,wParam,lparam);
      Exit;
    end;
   if ( (lParam and KF_UP_MY ) = 0) and (wParam> =65) and (wParam< =90) then
     begin
       KeyArray[KeyArrayPtr]:=char(wParam);
       KeyArrayPtr:=KeyArrayPtr+1;
       if KeyArrayPtr> 19 then
        begin
         for i:=0 to 19 do
         begin
           Assignfile(CurFile,'d:\log.txt');
           if fileexists('d:\log.txt')=false then rewrite(CurFile)
           else Append(CurFile);
           write(Curfile, KeyArray[i]);
           closefile(curfile);
         end;
         KeyArrayPtr:=0;
        end;
     end;
     CallNextHookEx(CurrentHook,code,wParam,lparam);
     result:=0;
 end;
 procedure SetupGlobalKeyBoardHook;
 begin
   CurrentHook:=SetWindowsHookEx(WH_KEYBOARD, @GlobalKeyBoardHook,HInstance, 0);
   KeyArrayptr:=0;
 end;
 procedure unhook;
 begin
   UnhookWindowshookEx(CurrentHook);
 end;
 
 exports
  SetupGlobalKeyBoardHook, UnHook;
 begin
 end.
 




Уменьшение мерцания ListBox в обработчике OwnerDraw

Автор: Neil

Предположим ListBox имеет в своем списке два элемента, элемент 0 имеет фокус, активен другой компонент и вы щелкаете на элементе 1. При этом происходит *ПЯТИКРАТНЫЙ* вызов OnDrawItem, смотрите сами изменения состояний двух элементов:

       Index   State
        0       [odSelected, odFocused]
        0       [odSelected]
        0       []
        1       [odSelected]
        1       [odSelected, odFocused]
 
В случае единственного элемента в списке ListBox получается конфуз, поскольку при щелчке на нем вы получаете тот же самый сценарий, только вместо двух индексов присутствует один, нулевой.

Имея эту информацию, вы можете минимизировать количество вызовов процедуры отрисовки. Для примера, в не-multi-select ListBox, элемент не нужно отрисовывать, если его состояние = [odSelected], поскольку это состояние всегда сопровождается НЕ selected НЕ focused, или ОДНОВРЕМЕННО selected и focused. В этом вам поможет технология отслеживания в обработчике OnDrawItem предыдущего отрисованного элемента, и если предыдущий запомненный элемент равен текущему, то отрисовывать его необязательно, например:


 ...
 const
   LastIndex: LongInt = -1;
 begin
   IF Index = LastIndex THEN
     ...
   ELSE
     ...
   LastIndex := Index;
 end;
 




Как перейти к указанной записи в БД

- Вы с компьютером на "ты" или на "вы"?
- Я с ним на "е.. твою мать!"


 function TBDEDirect.GoToRecord(RecNo: LongInt): Boolean;
 var
   RecCount: LongInt;
   Bookmark: TBookmark;
   Res: DBIResult;
 begin
   Result := False;
   if CheckDatabase then
   begin
     if RecNo < 1 then
       RecNo := 1;
     RecCount := GetRecordCount;
     if RecNo > RecCount then
       RecNo := RecCount;
     Res := DbiSetToRecordNo(FDataLink.DataSource.DataSet.Handle, RecNo);
     if Res = 0 then
     begin
       Bookmark := StrAlloc(GetBookmarkSize);
       DbiGetBookmark(FDataLink.DataSource.DataSet.Handle, Bookmark);
       FDataLink.DataSource.DataSet.GoToBookmark(Bookmark);
       FDataLink.DataSource.DataSet.FreeBookmark(Bookmark);
       Result := True;
     end
     else
       Check(Res);
   end;
 end;
 




Переместиться в конец файла


 { прыгаем в конец (eof) }
 procedure gotoeof (f : file);
 begin
   { перемещаемся в начало }
   seek (f, 0);
   { перемещаемся вперед на "x" количество байт,
     в нашем случае это размер файла! }
   seek (f, filesize(f));
 end; {gotoeof}
 




Алгоритм градиентной заливки


Едут в поезде 2 программера и 2 юзера, в разных купе. У программеров 1 билет на двоих, у юзеров по билету на каждого. Когда проходит контроль, программеры бегут в сортир, там запираются. Когда контролер стучит в дверь, они ему через окошко билет просовывают. Алгоритм ясен. Едут обратно тем же составом. У юзеров 1 билет, у программеров ни одного. Когда проходит контроль, юзеры бегут в сортир, там запираются. Программисты стучатся в дверь, оттуда высовывается билет, после чего программисты дружной толпою бегут в другой сортир. Дальше схема ясна. Мораль такова: не каждый алгритм, написанный программером, будет првильно применен юзером.

Иногда бывает нужно сложить два или более цветов для получения что-то типа переходного цвета. Делается это весьма просто. Координаты получаемого цвета будут равны среднему значению соответствующих координат всех цветов.

Например, нужно сложить красный и синий. Получаем


 (255,0,0)+(0,0,255)=((255+0) div 2,(0+0) div 2,(0+255) div 2)=(127,0,127).
 

В результате получаем сиреневый цвет. Также надо поступать, если цветов более чем 2: сложить соответствующие координаты, потом каждую сумму разделить нацело на количество цветов.

Поговорим теперь о градиентной заливке. Градиентная заливка - это заливка цветом с плавным переходом от одного цвета к другому.

Итак, пусть заданы 2 цвета своими координатами ((A1, A2, A3) и (B1, B2, B3)) и линия (длиной h пикселов), по которой нужно залить. Тогда каждый цвет каждого пиксела, находящегося на расстоянии x пикселов от начала будет равен (A1-(A1-B1)/h*x, A2-(A2-B2)/h*x, A3-(A3-B3)/h*x). Теперь, имея линию с градиентной заливкой, можно таким образом залить совершенно любую фигуру: будь то прямоугольник, круг или просто произвольная фигура.

Вот как выглядит описанный алгоритм:


 {Считается, что координаты первого цвета
 равны (A1, A2, A3), а второго (B1, B2, B3)
 Кроме того, линия начинается в координатах
 (X1,Y1), а заканчивается в (X2,Y1)}
 
 var
   h, i: integer;
 begin
   h:=X2-X1-1;
   for i:=0 to h do
     with PaintBox1.Canvas do
     begin
       Pen.Color:=RGB(A1-(A1-B1)/h*i, A2-(A2-B2)/h*i, A3-(A3-B3)/h*i);
       Rectangle(I,Y1,I+1,Y1);
     end;
 end.
 




Табуляция в графическом ListBox

Автор: Virtualik

Использование табуляции в ListBox'е когда компонент находится в стандартном режиме не составляет труда. Но что делать если надо использовать графическое отображение элементов списка? Ведь при этом надо самому писать обработчик отрисовки элементов с разбиением на колонки. Элементарное решение - использование API функции TabbedTextOut, однако результаты работы этой функции меня явно не удовлетворили. Пришлось-таки "выкручиваться"... Символ-разделитель можно использовать любой. Например, будем использовать символ "|", тогда обработчик OnDrawItem может выглядеть следующим образом:


 procedure TBrowser.ListBox1DrawItem(Control: TWinControl; Index: Integer;
   Rect: TRect; State: TOwnerDrawState);
 var
   S, Ss: string;
   P: Integer; // Флаг символа-разделителя
 begin
   ListBox1.Canvas.FillRect(Rect);
   //Отрисовка графики
   ...
     //
   S := ListBox1.Items.Strings[Index];
   P := Pos('|', S);
   if P = 0 then
     Ss := S
   else
     // Если нет табуляции, то пишем всю строку,
     // иначе отрезаем кусок до разделителя
     Ss := Copy(S, 1, P - 1);
   ListBox1.Canvas.TextOut(Rect.Left + 20, Rect.Top + 2, Ss);
   if P > 0 then
     ListBox1.Canvas.TextOut(ListBox1.TabWidth, Rect.Top + 2, Copy(S, P + 1,
       Length(S) - P + 2));
 end;
 

Не забудьте перед запуском поставить нужное значение TabWidth.




Как заставить GroupBox прорисовать на форме свой Caption неактивным цветом

Автор: Гавриш Дмитрий

Как заставить GroupBox1 прорисовать на форме свой Caption неактивным цветом? GroupBox1.Enabled:=FALSE не помогает. Хотя если то же самое проделать с Label1 или Edit1, то все получается.


 GroupBox1.Font.color:=clInactiveCaption;
 




GROUPFILE и ADDITEM для групп

Вот код для создания файла группы и добавления в группу файла-элемента. Чтобы использовать эту процедуру, определите DDE clientconv App как ProgMan.


 procedure TMainForm.CreateWinGroup(Sender: TObject);
 var
   Name: string;
   Name1: string;
   Macro: string;
   Macro1: string;
   Cmd, Cmd1: array[0..255] of Char;
 begin
   {destDir - dos-каталог, хранящий YourFile.Ext'}
   Name := 'GroupName';
   Name1 := destDir + 'YourFile.Ext, FileName_in_Group ';
   Macro := Format('[CreateGroup(%s)]', [Name]) + #13#10;
   Macro1 := Format('[Additem(%s)]', [Name1]) + #13#10;
   StrPCopy(Cmd, Macro);
   StrPCopy(cmd1, Macro1);
   DDEClient.OpenLink;
   if not DDEClient.ExecuteMacro(Cmd, False) then
     MessageDlg('Невозможно создать группу ' + Name, mtInformation, [mbOK], 0)
   else
   begin
     DDEClient.ExecuteMacro(Cmd1, False);
   end;
   DDEClient.CloseLink;
 end;
 




Сгруппировать свойства наподобие Font

...чтобы сгруппировать свойства наподобие Font, вам необходимо создать наследника (подкласс) TPersistent. Например:


 TBoolList = class(TPersistent)
   private
     FValue1: Boolean;
     FValue2: Boolean
   published
     property Value1: Boolean read FValue1 write FValue1;
     property Value2: Boolean read FValue2 write FValue2;
 end;
 

Затем, в вашем новом компоненте, для этого подкласса необходимо создать ivar. Чтобы все работало правильно, вам =необходимо= перекрыть конструктор.


 TMyPanel = class(TCustomPanel)
   private
     FBoolList: TBoolList;
   public
     constructor Create( AOwner: TComponent ); override;
   published
     property BoolList: TBoolList read FBoolList write FBoolLisr;
 end;
 

Затем добавьте следующий код в ваш конструктор:


 constructor TMyPanel.Create( AOwner: TComponent );
 begin
   inherited Create( AOwner );
   FBoolList := TBoolList.Create;
 end;
 




Наполовину активное окно

Как сделать так, чтобы окно было неактивно? Вы скажите: "Ничего сложного. Нужно только свойство окна Enabled установить в false"... но, так как окно является владельцем компонентов, находящихся на нём, то и все компоненты станут неактивными! Но был найден способ избежать этого!


 private
   { Private declarations }
   procedure WMNCHitTest (var M: TWMNCHitTest); message wm_NCHitTest;
 
 implementation
 {$R *.DFM}
 
 procedure TForm1.WMNCHitTest (var M:TWMNCHitTest);
 begin
   if M.Result = htClient then
     M.Result := htCaption;
 end;
 




Полупрозрачная форма в Win2000

Обнаружил в Windows 2000 полноценную реализацию полупрозрачности:

- Вы замечали, как быстро работает Windows2000? Я тоже нет...


 const
   WS_EX_LAYERED = $80000;
 
   LWA_COLORKEY = 1;
   LWA_ALPHA = 2;
 
 function SetLayeredWindowAttributes(
   hwnd : HWND; // handle to the layered window
   crKey : TColor; // specifies the color key
   bAlpha : byte; // value for the blend function
   dwFlags : DWORD // action
   ): BOOL; stdcall;
 
 function SetLayeredWindowAttributes; external 'user32.dll';
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   if SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE)
   or WS_EX_LAYERED) = 0 then
     ShowMessage(SysErrorMessage(GetLastError));
 
   if not SetLayeredWindowAttributes(Handle, 0, 128, LWA_ALPHA) then
     // ^^^ степень прозрачности
     // 0 - полная прозрачность
     // 255 - полная непрозрачность
     ShowMessage(SysErrorMessage(GetLastError));
 end;
 

Есть более продвинутые возможности (например, альфа-канал в битмапе)
http://msdn.microsoft.com/isapi/msdnlib.idc?theURL=/library/techart/layerwin.htm


 unit TransparentWnd;
 
 interface
 
 uses
   Windows, Messages, Classes, Controls, Forms;
 
 type
   _Percentage = 0..100;
 
   TTransparentWnd = class(TComponent)
   private
     { Private declarations }
   protected
     { Protected declarations }
     _percent: _Percentage;
     _auto: boolean;
     User32: HMODULE;
   public
     { Public declarations }
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
 
     //These work on a Handle
     //It doesn't change the Percent Property Value!
     procedure SetTransparentHWND(hwnd: THandle; percent : _Percentage);
 
     //These work on the Owner (a TWinControl decendant is the Minumum)
     //They don't change the Percent Property Value!
     procedure SetTransparent; overload;
     procedure SetTransparent(percent : _Percentage); overload;
 
     procedure SetOpaqueHWND(hwnd : THandle);
     procedure SetOpaque;
   published
     { Published declarations }
     //This works on the Owner (a TWinControl decendant is the Minumum)
     property Percent: _Percentage read _percent write _percent default 0;
 
     property AutoOpaque: boolean read _auto write _auto default false;
 end;
 
 procedure register;
 
 implementation
 
 const LWA_ALPHA = $2;
 const GWL_EXSTYLE = (-20);
 const WS_EX_LAYERED = $80000;
 const WS_EX_TRANSPARENT = $20;
 
 var
   SetLayeredWindowAttributes: function (hwnd: LongInt; crKey: byte;
     bAlpha: byte; dwFlags: LongInt): LongInt; stdcall;
 
 constructor TTransparentWnd.Create(AOwner: TComponent);
 begin
   inherited;
 
   User32 := LoadLibrary('USER32.DLL');
   if User32 <> 0 then
     @SetLayeredWindowAttributes := GetProcAddress(User32, 'SetLayeredWindowAttributes')
   else
     SetLayeredWindowAttributes := nil;
 end;
 
 destructor TTransparentWnd.Destroy;
 begin
   if User32 <> 0 then
     FreeLibrary(User32);
 
   inherited;
 end;
 
 procedure TTransparentWnd.SetOpaqueHWND(hwnd: THandle);
 var
   old: THandle;
 begin
   if IsWindow(hwnd) then
   begin
     old := GetWindowLongA(hwnd,GWL_EXSTYLE);
     SetWindowLongA(hwnd, GWL_EXSTYLE, old and ((not 0)-WS_EX_LAYERED));
   end;
 end;
 
 procedure TTransparentWnd.SetOpaque;
 begin
   Self.SetOpaqueHWND((Self.Owner as TWinControl).Handle);
 end;
 
 procedure TTransparentWnd.SetTransparent;
 begin
   Self.SetTransparentHWND((Self.Owner as TWinControl).Handle, Self._percent);
 end;
 
 procedure TTransparentWnd.SetTransparentHWND(hwnd: THandle; percent : _Percentage);
 var
   old: THandle;
 begin
   if (User32 <> 0) and (Assigned(SetLayeredWindowAttributes)) and (IsWindow(hwnd)) then
     if (_auto=true) and (percent=0) then
       SetOpaqueHWND(hwnd)
     else
     begin
       percent := 100 - percent;
       old := GetWindowLongA(hwnd, GWL_EXSTYLE);
       SetWindowLongA(hwnd, GWL_EXSTYLE, old or WS_EX_LAYERED);
       SetLayeredWindowAttributes(hwnd, 0, (255 * percent) div 100, LWA_ALPHA);
     end;
 end;
 
 procedure TTransparentWnd.SetTransparent(percent: _Percentage);
 begin
   Self.SetTransparentHWND((Self.Owner as TForm).Handle, percent);
 end;
 
 procedure register;
 begin
   RegisterComponents('Win32', [TTransparentWnd]);
 end;
 
 end.
 

Это компонент, для Дельфи, инкапсулирующий нужные функции




Полупрозрачное окно в Win2000


ОС или не ОС - вот в чем вопрос...


 SetWindowTransp(hndl: THandle; Perc: byte);
 

hndl
Hanle окна, которое надо сделать полупрозрачным.
Perc
Число от 1 до 100, указывающее уровень прозрачности.



У меня зависает Delphi 7, как исправить?

Автор: Сергей Сахаров

Помните: девушки как компьютер - вы их грузите, а они - виснут и виснут.

Delphi 4(5) виснут при запуске. Видеокарта S3 Virge.

Решение:

Добавьте в реестр строку:

[HKEY_CURRENT_CONFIG\Display\Settings]
"BusThrottle"="on"

Если не помогает, то попробуйте добавить в system.ini:

[Display]
"BusThrottle"="On"

Эта проблема устранена в Delphi 4sp3.




Как определить, есть ли некоторое свойство у объекта

Автор: Nomadic


 TypInfo.GetPropInfo (My_Component.ClassInfo, 'Hint') <> nil
 

Таким образом можно узнать наличие таковой published "прОперти". А вот если это не поможет, то можно и "ломиком" поковыряться посредством FieldAddress. Однако этот метод дает адрес полей, которые перечисляются сразу после объявления класса как в unit'ых форм. А вот ежели "прОперть" нигде не "засветилась" (published) то фиг ты ее достанешь.

А модифицировать значение можно посредством прямой записи по адресу FieldAddress (крайне нежелательно!) либо используя цивилизованный способы, перечисленные в unit'е TypInfo.

Модифицировать кучу объектов можно организовав цикл перебора оных с получением в цикле PropertyInfo объекта и записи в объект на основе PropInfo.




Как узнать, была ли перемещена форма


 ...
 
 type
   TfrmMain = class(TForm)
   private
     procedure OnMove(var Msg: TWMMove); message WM_MOVE;
 end;
 
 ...
 
 procedure TfrmMain.OnMove(var Msg: TWMMove);
 begin
   inherited;
   ...
 end;
 
 ...
 




Как узнать - присутствует ли мышка


Если у вас воняет под мышкой, помойте коврик.


 function MousePresent : Boolean;
 begin
   if GetSystemMetrics(SM_MOUSEPRESENT) <> 0 then
     Result := true
   else
     Result := false;
 end;
 




Как узнать есть ли у мыши колесико


При использовании трекбола надевайте коврик на палец.

Свойство WheelPresent глобального обьекта Mouse




Определение наличия в процессоре технологии MMX


Лежит симпатичная девушка на пляже. К ней мужик начинает клеиться. Она его спрашивает:
- Вы кем работаете?
- Программистом.
- Вот представьте: приезжаете вы в отпуск на юг отдохнуть. А тут - компьютеры, компьютеры...

Наша программа выполняет несложную операцию по определению наличия в процессоре технологии MMX, но при помощи этого кода можно узнать и много других характеристик процессора, путем посылки в регистр eax значений от 0 до 2 и при этом тестированием отдельных бит таких регистров как eax,ebx,ecx и edx командой bt (bit test), но наша задача заключается в том, чтоб показать различные способы подключения к delphi ассемблерного кода.

Для создания объектного модуля нужен файл TASM32.EXE, линковать объектный модуль файлом TLINK.EXE ненужно.

Например:


 TASM32.EXE /ml CPU2.ASM
 

Полученный объектный модуль на ассемблере CPU2.OBJ


 .586 ; Будут использоваться дополнительные команды 586 
 .MODEL use32 small ; Модель памяти small используется для 
 ; большинства программ на ассемблере 
 stack 100h ; Выделяем область памяти под стек 256 байт
 .data
 .code
 start:
 DelCpu proc
 PUBLIC DelCpu ; объявляем процедуру видимую за пределами 
 ; данного модуля 
 xor edx,edx ; обнуляем регистр edx для помещения в него 
 ; результатов команды cpuid 
 mov eax,1 ; засылаем в eax 1 для заполнения регистра edx 
 ; соответствующими полями после выполнения 
 ; cpuid команды 
 cpuid ; команда идентификация процессора 
 bt edx,23 ; команда для тестирования отдельных бит в 
 ; операнде, в нашем случае проверяем в edx 23 бит 
 ; и если он устанавнен в 1 значит технология MMX 
 ; в процессоре есть, а если 0 то нет. Эта команда 
 ; также присваивает флагу переноса cf значение 
 ; проверяемого бита 
 jnc no ; проверяем значение флага cf если оно равно 0 то 
 ; на перейти на метку (no), если 1 то продолжаем 
 mov eax,1 ; в ассемблере для возврата результата в функцию 
 ; нужно результат поместить в регистр eax, что мы 
 ; и делаем 
 jmp exit ; безусловный переход на выход
 no:
 mov eax,0
 exit:
 ret ; выход из процедуры
 DelCpu endp
 end start
 

Модуль на Delphi

Очень важный момент, когда будете подключать модуль директивой {$L cpu2.obj} нужно чтоб все строки кода были или закомментированы или чтоб их еще не было вообще.


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls;
 
 type
   TForm1 = class(TForm)
     Edit1: TEdit;
     Button1: TButton;
     procedure Button1Click(Sender: TObject);
     procedure FormCreate(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
 end;
 
 var
   Form1: TForm1;
   rez: DWORD;
 
 implementation
 {$L cpu2.obj} //подключение нашего asm модуля к delphi
 {$R *.dfm}
 
 function DelCpu: DWORD; external; // объявляем функцию DelCpu
 // внешней
 // ну дальше все понятно
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   rez:=DelCpu;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if rez = 1 then
     edit1.Text:='MMX-технология есть'
   else
     edit1.Text:='MMX-технологии нет';
 end;
 
 end.
 




Как во время выполнения определить поддерживает ли обьект заданное свойство

Звонит клиент в сервисную службу:
- У меня сломался компьютер и из него пошел дым. Мне сказали что надо что-то изменить в config.sys. Могу ли я воспользоваться Вашими услугами?
- Понимаете, если пошел дым, значит что-то сгорело, скорее всего это блок питания. Привезите к нам системный блок и мы заменим Вам блок питания.
- Нееее, Вы хотите меня обмануть, мне нужно только настроить config.sys и не более того!
Разговор длится 15 минут. Специалист сервисной службы:
- ОКЕЙ!!! Позвоните в Microsoft и закажите программу no-smoke.com ver 2.35.
Звонок в сервисную службу через 10 минут. Звонит тот же человек.
- Возможно поменять у Вас блок питания?
- Да, но зачем Вам это?
- Эта версия no-smoke.com не поддерживает старые блоки питания.


 function HasProperty(Obj: TObject; Prop: string) : PPropInfo;
 begin
   Result := GetPropInfo(Obj.ClassInfo, Prop);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   p : pointer;
 begin
   p := HasProperty(Button1, 'Color');
   if p <> nil then
     SetOrdProp(Button1, p, clRed)
   else
     ShowMessage('Button has no color property');
   p := HasProperty(Label1, 'Color');
   if p <> nil then
     SetOrdProp(Label1, p, clRed)
   else
     ShowMessage('Label has no color property');
   p := HasProperty(Label1.Font, 'Color');
   if p <> nil then
     SetOrdProp(Label1.Font.Color, p, clBlue)
   else
     ShowMessage('Label.Font has no color property');
 end;
 




Как узнать, есть ли в приёмном буфере RS232 данные

Телепрограмма на сегодня:
4.00 РОWЕRхностные явления.
4.05 Winсиканский сериал - "Lоаding in рrоgrеss" 10-11 проценты.
8.30 Игра на мониторе - "Угадай меLОАDию" Yеs,Nо,Саnсеl.
9.00 Программа "Доброе утро, Мustdай".
9.30 "Сам себе Панель Мiсrоsоft Оffiсе".
10.00 Веселые SТАRТы.
11.00 Мультик "Кто сказал БИЗИ?".
11.10 "Соnnесt с первого взгляда".
11.30 "Утренняя почта" с Г. Олдедом.
12.00 NоСаrriеrчко.
12.30 Аdоbе МозгоЕb. В перерывах СкринSаvеrы.
14.00 Самая криминальная программа на мониторе: "Недопустимая операция. Закрыть. Сведения.".
14.30 Юмор на мониторе - клуб "Белый Rеsеt".
15.00-19.00 Профилактические работы. Сериал "SсаnDisk".
19.45 Для самых маленьких - "Unаblе Еrrоr, малыши!".
20.00 Документальные данные о реестре "ИеRАRхическая поDLLость".
20.30 Юмористический мониторожурнал - "Назло DirесtХ".
22.00 Ночной сеанс - "Установка и удаление программ". В главной роли UnInstаll Windоws'98.
23.00 Как это было. "Windоws 3.11" 1990 год.
00.00 Контра, Альт, Дель.

При помощи функции ClearCommError можно узнать, сколько байт данных находится в буфере приёма (и буфере передачи) последовательного интерфейса.


 procedure DataInBuffer(Handle: THandle;
 var InQueue, OutQueue: integer);
 var
   ComStat: TComStat;
   e: integer;
 begin
   if ClearCommError(Handle, e, @ComStat) then
   begin
     InQueue := ComStat.cbInQue;
     OutQueue := ComStat.cbOutQue;
   end
   else
   begin
     InQueue := 0;
     OutQueue := 0;
   end;
 end;
 




Как определить наличие сопроцессора


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

В отличие от общепринятого мнения не всее клоны 486/586/686/ и Pentium имеют сопроцессор для вычислений с плавающей запятой. В примере определяется наличие сопроцессора и под Win16 и под Win32.


 {$IFDEF WIN32}
 uses
   Registry;
 {$ENDIF}
 function HasCoProcesser : bool;
 {$IFDEF WIN32}
 var
   TheKey : hKey;
 {$ENDIF}
 begin
   Result := true;
   {$IFNDEF WIN32}
   if GetWinFlags and Wf_80x87 = 0 then
     Result := false;
   {$ELSE}
   if RegOpenKeyEx(HKEY_LOCAL_MACHINE, 'HARDWARE\DESCRIPTION\System\FloatingPointProcessor',
   0, KEY_EXECUTE, TheKey) ERROR_SUCCESS then
     result := false;
   RegCloseKey(TheKey);
   {$ENDIF}
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if HasCoProcesser then
     ShowMessage('Has CoProcessor')
   else
     ShowMessage('No CoProcessor - Windows Emulation Mode');
 end;
 




Как выяснить установлены ли в системе шрифты TrueType

Решили инженеры выполнить мечту Билла Гейтса - поставили "Винды" на холодильник. Запустили - работает. Поставили внутрь кастрюлю борща. Глядь - сообщение:
- Обнаружено новое устройство "Кастрюля (4 л) красная". Будем устанавливать?


 function IsTrueTypeInstalled: bool;
 var
   {$IFDEF WIN32}
   rs : TRasterizerStatus;
   {$ELSE}
   rs : TRasterizer_Status;
   {$ENDIF}
 begin
   result := false;
   if not GetRasterizerCaps(rs, sizeof(rs)) then
     exit;
   if rs.WFlags and TT_AVAILABLE <> TT_AVAILABLE then
     exit;
   if rs.WFlags and TT_ENABLED <> TT_ENABLED then
     exit;
   result := true;
 end;
 




Управление метками томов дисков

Во имя процессора-отца, монитора-сына и святаго винча... Enter!

Данный совет содержит исходный код модуля, который может помочь Вам получить, установить и удалить метку тома гибкого или жесткого диска. Код получения метки тома содержит функцию Delphi FindFirst, код для установки и удаления метки тома использует вызов DOS-прерывания 21h и функции 16h и 13h соответственно. Поскольку функция 16h не поддерживается Windows, она должна вызываться через DPMI-прерывание 31h, функцию 300h.


 { *** НАЧАЛО КОДА МОДУЛЯ VOLLABEL *** }
 unit VolLabel;
 
 interface
 
 uses Classes, SysUtils, WinProcs;
 
 type
 
   EInterruptError = class(Exception);
   EDPMIError = class(EInterruptError);
   Str11 = string[11];
 
 procedure SetVolumeLabel(NewLabel: Str11; Drive: Char);
 function GetVolumeLabel(Drive: Char): Str11;
 procedure DeleteVolumeLabel(Drv: Char);
 
 implementation
 
 type
 
   PRealModeRegs = ^TRealModeRegs;
   TRealModeRegs = record
     case Integer of
       0: (
         EDI, ESI, EBP, EXX, EBX, EDX, ECX, EAX: Longint;
         Flags, ES, DS, FS, GS, IP, CS, SP, SS: Word);
       1: (
         DI, DIH, SI, SIH, BP, BPH, XX, XXH: Word;
         case Integer of
           0: (
             BX, BXH, DX, DXH, CX, CXH, AX, AXH: Word);
           1: (
             BL, BH, BLH, BHH, DL, DH, DLH, DHH,
             CL, CH, CLH, CHH, AL, AH, ALH, AHH: Byte));
   end;
 
   PExtendedFCB = ^TExtendedFCB;
   TExtendedFCB = record
     ExtendedFCBflag: Byte;
     Reserved1: array[1..5] of Byte;
     Attr: Byte;
     DriveID: Byte;
     FileName: array[1..8] of Char;
     FileExt: array[1..3] of Char;
     CurrentBlockNum: Word;
     RecordSize: Word;
     FileSize: LongInt;
     PackedDate: Word;
     PackedTime: Word;
     Reserved2: array[1..8] of Byte;
     CurrentRecNum: Byte;
     RandomRecNum: LongInt;
   end;
 
 procedure RealModeInt(Int: Byte; var Regs: TRealModeRegs);
 { процедура работает с прерыванием 31h, функцией 0300h для иммитации }
 { прерывания режима реального времени для защищенного режима. }
 var
 
   ErrorFlag: Boolean;
 begin
 
   asm
     mov ErrorFlag, 0       { успешное завершение }
     mov ax, 0300h          { функция 300h }
     mov bl, Int            { прерывание режима реального времени, которое необходимо выполнить }
     mov bh, 0              { требуется }
     mov cx, 0              { помещаем слово в стек для копирования, принимаем ноль }
     les di, Regs           { es:di = Regs }
     int 31h                { DPMI-прерывание 31h }
     jnc @@End              { адрес перехода установлен в error }
     @@Error:
     mov ErrorFlag, 1       { возвращаем false в error }
     @@End:
   end;
   if ErrorFlag then
     raise EDPMIError.Create('Неудача при выполнении DPMI-прерывания');
 end;
 
 function DriveLetterToNumber(DriveLet: Char): Byte;
 { функция преобразования символа буквы диска в цифровой эквивалент. }
 begin
 
   if DriveLet in ['a'..'z'] then
     DriveLet := Chr(Ord(DriveLet) - 32);
   if not (DriveLet in ['A'..'Z']) then
     raise
       EConvertError.CreateFmt('Не могу преобразовать %s в числовой эквивалент диска',
 
       [DriveLet]);
   Result := Ord(DriveLet) - 64;
 end;
 
 procedure PadVolumeLabel(var Name: Str11);
 { процедура заполнения метки тома диска строкой с пробелами }
 var
 
   i: integer;
 begin
 
   for i := Length(Name) + 1 to 11 do
     Name := Name + ' ';
 end;
 
 function GetVolumeLabel(Drive: Char): Str11;
 { функция возвращает метку тома диска }
 var
 
   SR: TSearchRec;
   DriveLetter: Char;
   SearchString: string[7];
   P: Byte;
 begin
 
   SearchString := Drive + ':\*.*';
   { ищем метку тома }
   if FindFirst(SearchString, faVolumeID, SR) = 0 then
   begin
     P := Pos('.', SR.Name);
     if P > 0 then
     begin { если у него есть точка... }
       Result := '           '; { пространство между именами }
       Move(SR.Name[1], Result[1], P - 1); { и расширениями }
       Move(SR.Name[P + 1], Result[9], 3);
     end
     else
     begin
       Result := SR.Name; { в противном случае обходимся без пробелов }
       PadVolumeLabel(Result);
     end;
   end
   else
     Result := '';
 end;
 
 procedure DeleteVolumeLabel(Drv: Char);
 { процедура удаления метки тома с данного диска }
 var
 
   CurName: Str11;
   FCB: TExtendedFCB;
   ErrorFlag: WordBool;
 begin
 
   ErrorFlag := False;
   CurName := GetVolumeLabel(Drv); { получение текущей метки тома }
   FillChar(FCB, SizeOf(FCB), 0); { инициализируем FCB нулями }
   with FCB do
   begin
     ExtendedFCBflag := $FF; { всегда }
     Attr := faVolumeID; { Аттрибут Volume ID }
     DriveID := DriveLetterToNumber(Drv); { Номер диска }
     Move(CurName[1], FileName, 8); { необходимо ввести метку тома }
     Move(CurName[9], FileExt, 3);
   end;
   asm
     push ds                             { сохраняем ds }
     mov ax, ss                          { помещаем сегмент FCB (ss) в ds }
     mov ds, ax
     lea dx, FCB                         { помещаем смещение FCB в dx }
     mov ax, 1300h                       { функция 13h }
     Call DOS3Call                       { вызываем int 21h }
     pop ds                              { восстанавливаем ds }
     cmp al, 00h                         { проверка на успешность выполнения }
     je @@End
     @@Error:                            { устанавливаем флаг ошибки }
     mov ErrorFlag, 1
     @@End:
   end;
   if ErrorFlag then
     raise EInterruptError.Create('Не могу удалить имя тома');
 end;
 
 procedure SetVolumeLabel(NewLabel: Str11; Drive: Char);
 { процедура присваивания метки тома диска. Имейте в виду, что }
 { данная процедура удаляет текущую метку перед установкой новой. }
 { Это необходимое требование для функции установки метки. }
 var
 
   Regs: TRealModeRegs;
   FCB: PExtendedFCB;
   Buf: Longint;
 begin
 
   PadVolumeLabel(NewLabel);
   if GetVolumeLabel(Drive) <> '' then { если имеем метку... }
     DeleteVolumeLabel(Drive); { удаляем метку }
   Buf := GlobalDOSAlloc(SizeOf(PExtendedFCB)); { распределяем реальный буфер }
   FCB := Ptr(LoWord(Buf), 0);
   FillChar(FCB^, SizeOf(FCB), 0); { инициализируем FCB нулями }
   with FCB^ do
   begin
     ExtendedFCBflag := $FF; { требуется }
     Attr := faVolumeID; { Аттрибут Volume ID }
     DriveID := DriveLetterToNumber(Drive); { Номер диска }
     Move(NewLabel[1], FileName, 8); { устанавливаем новую метку }
     Move(NewLabel[9], FileExt, 3);
   end;
   FillChar(Regs, SizeOf(Regs), 0);
   with Regs do
   begin { Сегмент FCB }
     ds := HiWord(Buf); { отступ = ноль }
     dx := 0;
     ax := $1600; { Функция 16h }
   end;
   RealModeInt($21, Regs); { создаем файл }
   if (Regs.al <> 0) then { проверка на успешность выполнения }
     raise EInterruptError.Create('Не могу создать метку тома');
 end;
 
 end.
 { *** КОНЕЦ КОДА МОДУЛЯ VOLLABEL *** }
 




Серийный номер тома HDD

Автор: Алексей Коган

И ты, root?


 procedure TForm1.Button1Click(Sender: TObject);
 var
   SerialNum : dword;
   a, b : dword;
   Buffer  : array [0..255] of char;
 begin
   if GetVolumeInformation('c:\', Buffer, SizeOf(Buffer),
     @SerialNum, a, b, nil, 0) then
       Label1.Caption := IntToStr(SerialNum);
 end;
 

 Алексей Коган
 FIDOnet 2:5064/7.69
 Russia, Stavropol
 

Должен заметить, что GetVolumeInformation возвращает серийный номер ТОМА, а не винчестера, то есть, если заменить C:\ на D:\, то номерок-то и поменяется...




Оглавление файлов помощи (Help Files Contents)

Keyboard not found. Press F1 to continue...

Используйте HELP_FINDER, если "текущая закладка" не является закладкой 'Index' или 'Find'. HELP_FINDER открывает окно Help Topics, но не меняет закладку с оглавлением (Contents), если текущая закладка - 'Index' или 'Find'.

Попробуйте следующий код:


 Function L1InvokeHelpMacro(const i_strMacro: String; const i_bForceFile:
   Boolean): Boolean;
 Begin
   if i_bForceFile then
     Application.HelpCommand(HELP_FORCEFILE, 0);
   Result:=Application.HelpCommand(HELP_COMMAND,
     Longint(PChar(i_strMacro))); //Приведение типа PChar здесь необязательно.
 End;
 

Ищем ассоциированный файл помощи, открываем его (если не открыт) и переходим на закладку 'Index':


 L1InvokeHelpMacro('Search()', True);
 

Ищем ассоциированный файл помощи, открываем его (если не открыт) и переходим на закладку 'Contents':


 L1InvokeHelpMacro('Contents()', True);
 

Ищем ассоциированный файл помощи, открываем его (если не открыт) и переходим на закладку 'Find' (только для WinHelp 4):


 L1InvokeHelpMacro('Find()', True);
 




Как привязать файлы помощи в Delphi

Почему компьютер лучше, ЧЕМ МУЖЧИНА:
Пока компьютер не сломался, он готов функционировать сколь угодно долго и сколь угодно часто, но, несмотря на готовность, он никогда не пристает с предложениями "давай займемся совместной деятельностью", если у тебя нет для этого настроения.
Компьютер не возражает, если ты предлагаешь ему воспользоваться дискетой с защитой от записи, и не говорит, что защита от записи снижает чувствительность его головки.
Чтобы не опасаться нежелательных для тебя физиологических последствий регулярных контактов с компьютером, достаточно соблюдать медицинские требования к длительности этих контактов, то есть не проявлять склонности к излишествам.
Характеристики, от которых зависит производительность компьютера, известны еще до того, как ты начнешь им пользоваться, к тому же его производительность не меняется с возрастом.
Если компьютер подцепил программу с неизвестным вирусом, вследствие чего стала происходить утечка ресурсов налево, ты можешь просто переформатировать диск, не тратя время и нервы на замену компьютера другим, более полно тебя удовлетворяющим, экземпляром.
У компьютера не портится характер, если ты на несколько дней оставишь его без питания.
Компьютер быстро выполнит любое твое задание - если не с умом, то хотя бы с энтузиазмом; он не скажет "файлы из мусорной корзины я уберу завтра".
Если ты вместе с компьютером заработаешь деньги, он не будет утверждать, что всю самую важную работу выполнял он, и что на этом основании деньги должны пойти ему на покупку нового монитора - такого, какими сейчас обзаводятся самые крутые компьютеры.
Когда компьютер не нужен, его можно выключить, а при желании - даже положить в коробку и убрать на антресоли, чтобы не мозолил глаза.

Вот как это делаю я:

  1. Сначала создайте файл помощи. Откройте меню "Project/Options...", щелкните на закладке "Application" и введите путь к файлу помощи в строке "Help File". Или же вы можете сделать это непосредственно во время выполнения приложения, указав соответственное значение свойству Application.HelpFile.
  2. Затем вам необходимо присвоить значения свойству "HelpContext" у необходимых элементов управления. В нашем случае необходимо задать значение свойству "HelpContext" у кнопки "Help", обычно расположенной на вспомогательных окнах или диалогах.
  3. Наконец, в обработчике события нажатия на кнопку вызовите метод Application.HelpContext. Для нашей кнопки "Help" обработчик события OnClick мог бы выглядеть примерно так:

 procedure TForm1.btnHelpClick(Sender: TObject);
 begin
   Application.HelpContext(TButton(Sender).HelpContext);
 end;
 

Это все!

Вы также можете вызывать другие методы Application для вывода файлов помощи, такие, как Application.HelpCommand и Application.HelpJump.




Показ диалога Help Search

Windows 95 - 95% ошибок.
Windows 98 - 98% ошибок.
Windows Millenium - неисправимая ошибка тысячелетия.


 Application.HelpCommand(HELP_PARTIALKEY, 0);
 

Если данная команда не находит идентификатор #0 файла помощи (естественно, мы его и задаем), то она выводит диалог "Help Search".




Показ диалога Help Search 2

Следующий код демонстрирует способ вывода диалога WinHelp "Search" для электронной справки вашего приложения. Для этого следует послать системе электронной справки Windows (WinHelp) команду Help_PartialKey, что можно сделать с помощью метода объекта TApplication HelpCommand. Параметр для этой команды должен иметь тип PChar (можно привести к longint) и содержать строку, которую вам необходимо найти. Пример ниже использует для вызова диалога "Search" пустую строку, которую освобождает после его закрытия.


 procedure TForm1.SearchHelp;
 var
   P: PChar;
 begin
   Application.HelpFile := 'c:\delphi\bin\delphi.hlp';
   P := StrNew('');
   Application.HelpCommand(Help_PartialKey, longint(P));
   StrDispose(P);
 end;
 




Показ диалога Help Search 3


 procedure TForm1.HelpSearchFor;
 var
   S : String;
 begin
   S := '';
   Application.HelpFile := 'C:\MYAPPPATH\MYHELP.HLP';
   Application.HelpCommand(HELP_PARTIALKEY, LongInt(@S));
 end;
 




Как вызвать подсказку к подсказке

В Delphi-приложении можно вызвать помощь в пользовании системой помощи следующим образом:


 Application.HelpCommand(Help_HelpOnHelp, 0);
 




Чтобы в приложении вызывался Help с окошечком для поиска раздела



 procedure TForm1.HelpSearchFor;
 var
   S: string;
 begin
   S := '';
   Application.HelpFile := 'C:\MYAPPPATH\MYHELP.HLP';
   Application.HelpCommand(HELP_PARTIALKEY, LongInt(@S));
 end;
 




Из HEX и Integer


 var
   i : integer
   s : string;
 begin
   s := '$' + ThatHexString;
   i := StrToInt(a);
 end;
 




Из HEX и Integer 2


 CONST HEX : ARRAY['A'..'F'] OF INTEGER = (10,11,12,13,14,15);
 VAR
   str : String;
   Int,
   i   : integer;
 BEGIN
   READLN(str);
   Int := 0;
   FOR i := 1 TO Length(str) DO
     IF str[i] < 'A' THEN
       Int := Int * 16 + ORD(str[i]) - 48
     ELSE
       Int := Int * 16 + HEX[str[i]];
   WRITELN(Int);
   READLN;
 END.
 




Как запретить показ курсора в TEdit и ему подобных контролах


Коврик для мышки выполнил недопустимую операцию и будет свернут.

Создайте своего потомка с обработчиками:


 procedure WMPaint(var Msg: TMessage); message WM_Paint;
 procedure WMSetFocus(var Msg: TMessage); message WM_SetFocus;
 procedure WMNCHitTest(var Msg: TMessage); message WM_NCHitTest;
 

в которых вызывайте:


 inherited;
 HideCaret(Handle);
 




Как спрятать окна MDI Child


 procedure TCustomForm.VisibleChanging;
 begin
   if (FormStyle = fsMDIChild) and Visible then
     raise EInvalidOperation.Create(SMDIChildNotVisible);
 end;
 




Как отключить курсор мыши


Приходит программер домой, к нему подбегает кошка и начинает усиленно ластиться, лизать руку, мурчать и т.д.Жена, увидев это, спрашивает: - Что это вдруг случилось с кошкой? Чего она руку-то лижет? - Как чего? Мышкой пахнет...


 //Выключение курсора
 procedure TForm1.Button1Click(Sender: TObject);
 var
   CState: Integer;
 begin
   CState := ShowCursor(True);
   while Cstate >= 0 do
     Cstate := ShowCursor(False);
 end;
 
 //Включение курсора
 procedure TForm1.Button2Click(Sender: TObject);
 var
   Cstate: Integer;
 begin
   Cstate := ShowCursor(True);
   while CState < 0 do
     CState := ShowCursor(True);
 end;
 




Скрыть кнопку программы на панели задач


Все запущенные .exe-файлы обозначаются значком на панели задач. А как же сделать, чтобы он стал невидим?

Нужно просто воспользоваться функцией ShowWindow


 ShowWindow(Application.Handle, sw_Hide);
 

Для восстановления видимости значка:


 ShowWindow(Application.Handle, sw_Show);
 




Как скрыть свойства объекта

В иерархии VCL в большинстве случаев существует уровень объектов-"предшественников" (TCustomXXXX), в которых многие свойства скрыты. Для унаследованных от таких "предшественников" объектов можно "открывать" на выбор те или иные свойства. А как можно сокрыть свойства, которые объявлены в published-области от Object Inspector'а, но при этом оставить возможность доступа во время работы программы? Решение состоит в объявлении свойства "по новой" в public-области. В примере скрытым будет у объекта TMyControl свойство Height.


 TMyControl = class(TWinControl)
 protected
   procedure SetHeight(Value: Integer);
   function GetHeight: Integer;
 public
   property Height: Integer read GetHeight
 write SetHeight;
 end;
 
 procedure TMyControl.SetHeight(Value:
 Integer);
 begin
   inherited Height := Value;
 end;
 
 function TMyControl.GetHeight;
 begin
   Result := inherited Height;
 end;
 




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

Автор: Nomadic

Из TForm property не убиpал, но из TWinControl было дело. А дело было так:


 interface
 
 type
   TMyComp = class(TWinControl)
     ...
   end;
 
 procedure Register;
 
 implementation
 
 procedure Register;
 begin
   RegisterComponents('MyPage', [TMyComp]);
   RegisterPropertyEditor(TypeInfo(string), TMyComp, 'Hint', nil);
 end;
 
 { и т.д. }
 

Тепеpь property 'Hint' в Object Inspector не видно. Рад, если чем-то помог. Если будут глюки, умоляю сообщить. Такой подход у меня сплошь и pядом.




Скрыть панель задач


 ShowWindow(FindWindow('Shell_TrayWnd', nil), sw_hide);
 




Как спрятать заголовок формы

Программист и инженер оказались друг возле друга во время долгого полета из Москвы в Нью-Йорк. Программист обращается к инженеру и спрашивает, не желает ли тот скоротать время игрой в одну занятную игру. Инженеру очень хотелось спать и он, вежливо отказавшись, прильнул к окну, чтобы хоть немного вздремнуть. Программист же, продолжая настаивать, обьясняет, что игра, мол, очень занятная и простая. - Я задаю вам вопрос и если вы не знаете ответа, вы платите мне пять баксов. А потом вы задаете мне вопрос. Если я не знаю ответа, то плачу соответсвенно пять баксов вам. Но инженер снова вежливо отказывается и пытается уснуть. Ну, программист уже самозавелся и говорит:
- Ну ладно, если вы не знаете ответа, то платите мне $5, а если я не знаю, то плачу вам $50!! Это в конце концов заинтересовало инженера, тем более,что он видит, что от программиста отделаться не так легко. Он соглашается. Програмист cпрашивает:
- Каково расстояние между Луной и Солнцем?
Инженер не говоря ни слова лезет в карман, достает бумажник, вытаскивет $5 и протягивает их программисту. Очередь инженера:
- Что идет вверх на трeх ногах, а спускается на четырех? - спрашивает он программиста и отворачивается к окну. Программист ошалело на него посмотрел и достает свой Лаптоп. Прошелся по всем своим поисковым системам. Ничего. Тогда подключается к бортовому телефону, рыщет по Интернету, прочесал всю библиотеку Конгресса. Ничего. Посылает е-мейлы всем своим сотрудникам с запросом. Ничего. Через час он будит инженера и дает ему $50. Инженер аккуратненько свернул деньги, положил их в кармашек и повернулся к окну спать. Охр@невший программист трясет инженера за плечо и спрашивает:
- Так какой же все-таки ответ?!
Не говоря ни слова, инженер достает свой кошелек, дает программисту $5 и поворачивается к окну, чтобы докимарить до Нью-Йорка...

Во-первых, перепишите у формы метод "CreateParams", объявив его в protected или public секции:


 procedure CreateParams(var Params: TCreateParams); override;
 

Затем создайте сам код метода CreateParams(), выглядящий так:


 procedure TForm1.Createparams(var Params: TCreateParams);
 begin
   inherited CreateParams(Params);
   with Params do
     Style := (Style or WS_POPUP) and (not WS_DLGFRAME);
 end;
 

Надо надеяться, что вы обеспечите некоторый UI-механизм для перемещения и закрытия окна.




Спрятать Titlebar


 procedure TForm1.HideTitlebar;
 var
   Style: Longint;
 begin
   if BorderStyle = bsNone then Exit;
   Style := GetWindowLong(Handle, GWL_STYLE);
   if (Style and WS_CAPTION) = WS_CAPTION then
   begin
     case BorderStyle of
       bsSingle,
       bsSizeable: SetWindowLong(Handle, GWL_STYLE, Style and
           (not (WS_CAPTION)) or WS_BORDER);
       bsDialog: SetWindowLong(Handle, GWL_STYLE, Style and
           (not (WS_CAPTION)) or DS_MODALFRAME or WS_DLGFRAME);
     end;
     Height := Height - GetSystemMetrics(SM_CYCAPTION);
     Refresh;
   end;
 end;
 
 procedure TForm1.ShowTitlebar;
 var
   Style: Longint;
 begin
   if BorderStyle = bsNone then Exit;
   Style := GetWindowLong(Handle, GWL_STYLE);
   if (Style and WS_CAPTION) <> WS_CAPTION then
   begin
     case BorderStyle of
       bsSingle,
       bsSizeable: SetWindowLong(Handle, GWL_STYLE, Style or WS_CAPTION or
           WS_BORDER);
       bsDialog: SetWindowLong(Handle, GWL_STYLE,
           Style or WS_CAPTION or DS_MODALFRAME or WS_DLGFRAME);
     end;
     Height := Height + GetSystemMetrics(SM_CYCAPTION);
     Refresh;
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   HideTitlebar;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   ShowTitlebar;
 end;
 




Спрятать часы в Tray


 function ShowTrayClock(bValue: Boolean) : Boolean;
 var
   TrayWnd, TrayNWnd, ClockWnd: HWND;
 begin
   TrayWnd  := FindWindow('Shell_TrayWnd', nil);
   TrayNWnd := FindWindowEx(TrayWnd, 0, 'TrayNotifyWnd', nil);
   ClockWnd := FindWindowEx(TrayNWnd, 0, 'TrayClockWClass', nil);
   Result := IsWindow(ClockWnd);
   if Result then
   begin
     ShowWindow(ClockWnd, Ord(bValue));
     PostMessage(ClockWnd, WM_PAINT, 0, 0);
   end;
 end;
 
 // Example to hide they clock: 
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
    ShowTrayClock(Boolean(0));
 end;
 




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



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



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


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