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

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


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

БОЛЬШОЙ FAQ ПО DELPHI



Как программно изменить LangDriver для таблиц dBase и Paradox

Автор: Nomadic

Откpываешь help и смотpишь:


 .......
 var List:TStrings;
 .......
 BEGIN
 .......
 List.Add ( 'LANGDRIVER=db866ru0 ');
 .......
 Session.ModifyDriver( 'DBASE', List );
 .......
 END;
 

Это действие я пpовожy пеpед откpытием таблицы

Автор: Ivan Sboev

Это о "русификации" таблицы. В таблицах dBase и Paradox имеется байт, который определяет CodePage содержимого таблицы. Раньше он не использовался и был зарезервирован. Тебе нужно его правильно установить. Это делается через DBD Restructure table. Если хочешь программно, можешь воспользоваться следующей процедурой:


 uses DbiTypes, DbiProcs, DbiErrs, DB, WinProcs, SysUtils;
 
 procedure ChangeLangDriver(DatabaseName, TableName, LDName: string);
 var
   TblExt: string;
   Database: TDatabase;
   TblDesc: CRTblDesc;
   OptDesc: FLDDesc;
   OptData: array[0..250] of Char;
   Cur: hDBICur;
   Rec: CFGDesc;
 begin
   if (TableName = '') or (LDName = '') then
     raise Exception.Create('Unknown TableName or LDName');
   Database := Session.OpenDatabase(DatabaseName);
   try
     if Database.IsSQLBased then
       raise Exception.Create(
         'Function ChangeLangDriver working only with dBase or Paradox tables');
     FillChar(OptDesc, SizeOf(OptDesc), #0);
     FillChar(TblDesc, SizeOf(TblDesc), #0);
     StrCopy(OptDesc.szName, 'LANGDRIVER');
     OptDesc.iLen := Length(LDName) + 1;
     with TblDesc do
     begin
       StrPCopy(szTblName, TableName);
       TblExt := UpperCase(ExtractFileExt(TableName));
       if TblExt = 'DBF' then
         StrCopy(szTblType, szDbase)
       else if TblExt = '.DB' then
         StrCopy(szTblType, szParadox)
       else
       begin
         AnsiToOEM(StrPCopy(OptData, DatabaseName), OptData);
         if DbiOpenCfgInfoList(nil, dbiREADONLY, cfgPersistent,
           StrPCopy(OptData, '\DATABASES\' + StrPas(OptData) + '\DB INFO\')
           Cur) <> DBIERR_NONE then
           raise Exception.Create('Unknown table type');
         try
           while DbiGetNextRecord(Cur, dbiNOLOCK, @Rec, nil) <> DBIERR_EOF do
             if StrComp(Rec.szNodeName, 'DEFAULT DRIVER') = 0 then
             begin
               StrCopy(szTblType, Rec.szValue);
               Break;
             end;
         finally
           Check(DbiCloseCursor(Cur));
         end;
       end;
       iOptParams := 1;
       pfldOptParams := @OptDesc;
       pOptData := @OptData;
     end;
     StrPCopy(OptData, LDName);
     Check(DbiDoRestructure(Database.Handle, 1, @TblDesc, nil,
       nil, nil, False));
   finally
     Session.CloseDatabase(Database);
   end;
 end;
 

Примеры использования:


 ChangeLangDriver( 'DBDEMOS', 'EMPLOYEE', 'ancyrr' );
 ChangeLangDriver( 'DBDEMOS', 'EMPLOYEE.DB', 'ancyrr' );
 ChangeLangDriver( 'C:\DELPHI\DEMOS\DATA', 'CLIENTS.DBF', 'db866ru0' );
 

LDName:
для D1 - имя .LD файла в каталоге IDAPI\LANGDRV;
для D2 и CB - из BDECFG32.HLP поле Short name в табличке по указателю language drivers, dBASE или поле Internal в табличке по указателю language drivers, Paradox;
для D3 и выше - не знаю так как у меня её нет, но думаю, что также, как и в D2.




Сменить язык

FIDO'шник решил блеснуть знанием английского языка. Заходит в пивную.
- Пива энд воблы. Ничего, что я по-англицки?

Эта программа при нажатии на Button1 меняет язык на следующий, при нажатии на Button2 – на русский, а на Button3 – на английский. Каждую секунду программа выводит в заголовок окна число, определяющее текущий язык.


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ActivateKeyboardLayout(HKL_NEXT, 0);
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   ActivateKeyboardLayout(LoadKeyboardLayout('00000419', 0), 0);
 end;
 
 procedure TForm1.Button3Click(Sender: TObject);
 begin
   ActivateKeyboardLayout(LoadKeyboardLayout('00000409', 0), 0);
 end;
 
 procedure TForm1.Timer1Timer(Sender: TObject);
 var
   s: array [0..63] of char;
 begin
   GetKeyboardLayoutName(s);
   Form1.Caption := s;
 end;
 




Изменение шрифта в Listbox

Вероятно иногда бывает полезным установить шрифт с фиксированной шириной символов в вашем Listbox.

Есть одно решение данной проблемы - использовать системные фиксированные шрифты - System-Fixed-Font (по крайней мере в Windows 3.11 -- как насчет Windows 95?). Единственную вещь, которую вы должны сделать - установить шрифт программным путем в момент создания формы.

Вот пример (здесь LB - ListBox), где шрифт устанавливается после добавления нескольких строк в ListBox:


 LB.Items.Clear;
 
 for i := 0 to (SL.Count)-1 do
 begin
   LB.Items.Add(Copy(SL.Strings[i], 1, j-1));
 end;
 
 { !!!!! ТЕПЕРЬ УСТАНАВЛИВАЕМ ЖЕЛАЕМЫЙ ШРИФТ !!!!! }
 { System_Fixed_Font или ANSI_Fixed_Font }
 SendMessage(LB.handle, wm_SetFont, GetStockObject(System_Fixed_Font), 1);
 
 




Поменять шрифт ListBox посылкой сообщения


   LB.Items.Clear;
 
   for i := 0 to (SL.Count)-1 do
   begin
     LB.Items.Add(Copy(SL.Strings[i], 1, j-1));
   end;
 
   SendMessage(LB.handle, wm_SetFont, GetStockObject(System_Fixed_Font), 1);
 




Как поменять приоритет моего приложения

Автор: Олег Кулабухов

ЯВА - московские сигареты, выпускаемые по лицензии Sun Microsystems.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   ProcessID: DWORD;
   ProcessHandle: THandle;
   ThreadHandle: THandle;
 begin
   ProcessID := GetCurrentProcessID;
   ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION,
     false, ProcessID);
   SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS);
   ThreadHandle := GetCurrentThread;
   SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL);
 end;
 




Подскажите, как на Oracle поменять compatible

Автор: Nomadic

Подскажите, как на Oracle 7.3.2.3 (Solaris x86) поменять compatible на 7.3.2.3 (c 7.1.0.0)?

Ставить в initmybase.ora

compatible = "7.3.2.3"
и после старта с новым параметром сделать
ALTER DATABASE RESET COMPABILITY;
И рестартовать базу.


Поменять владельца компонента


Молодой человек хочет через компьютер найти жену. Он хочет, чтобы она была брюнетка, небольшого роста, скромно одевалась, была общительной и хорошо плавала. компьютер выдал рекомендацию: "Вам подходит самка пингвина."


 unit ChOwn1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     ButtonChange: TButton;
     ButtonList: TButton;
     ListBox1: TListBox;
     procedure ButtonChangeClick(Sender: TObject);
     procedure ButtonListClick(Sender: TObject);
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 uses ChOwn2;
 
 {$R *.DFM}
 
 procedure TForm1.ButtonChangeClick(Sender: TObject);
 var
   AComp: TComponent;
 begin
   if Assigned (Button1) then
   begin
     // change parent
     Button1.Parent := Form2;
     // change owner
     AComp := Button1;
     RemoveComponent (AComp);
     Form2.InsertComponent (AComp);
   end;
 end;
 
 procedure TForm1.ButtonListClick(Sender: TObject);
 var
  I: Integer;
 begin
   ListBox1.Items.Clear;
   for I := 0 to ComponentCount - 1 do
     ListBox1.Items.Add (Components[I].Name);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ShowMessage ('My owner is ' +
     ((Sender as TButton).Owner as TForm).Caption);
 end;
 
 end.


 unit ChOwn2;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls;
 
 type
   TForm2 = class(TForm)
     ButtonList: TButton;
     ListBox1: TListBox;
     procedure ButtonListClick(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form2: TForm2;
 
 implementation
 
 {$R *.DFM}
 
 
 procedure TForm2.ButtonListClick(Sender: TObject);
 var
  I: Integer;
 begin
   ListBox1.Items.Clear;
   for I := 0 to ComponentCount - 1 do
     ListBox1.Items.Add (Components[I].Name);
 end;
 
 end.

Загрузить весь проект




Как сменить пароль (master password) для таблицы Paradox

Автор: Nomadic


 var
   db: TDatabase;
   Desc: CRTblDesc;
 begin
   db := PriceTable.OpenDatabase;
   FillChar( Desc, SizeOf( Desc ), #0 );
   StrCopy( Desc.szTblName, PChar( PriceTable.TableName ) );
   StrCopy( Desc.szTblType, szParadox );
   StrCopy( Desc.szPassword, 'password' );
   Desc.bProtected := TRUE;
   Check( DbiDoRestructure( db.Handle, 1, @Desc, nil, nil, nil, FALSE ) );
 end;
 




Изменение свойств печати во время ее выполнения

Как разрешить изменения свойств принтера (например, лоток с бумагой, ориентация и др.) между страницами печати одного документа в шести шагах.

(В совете также приведен пример изменения поддона с бумагой...)

*** ШАГИ ***
  1. Создайте копию модуля Printers.pas и переименуйте его в NewPrint.pas.

    ***НЕ делайте изменения в самом модуле Printers.pas, если вы сделаете это, то получите во время компиляции приложения ошибку "Unable to find printers.pas" (не могу найти printer.pas). (Я уже получае ее, поэтому и упоминаю об этом здесь...)***

  2. Переместите модуль NewPrint.pas в директорию Lib.

    (Используйте "C:\Program Files\Borland\Delphi Х\Lib" )

  3. Измените ИМЯ МОДУЛЯ на NewPrint.pas

    с:

 unit Printers
 

на:


 unit NewPrint
 

  1. Добавьте декларацию следующего PUBLIC метода класса TPrinter в секции Interface модуля NewPrint.pas:

 procedure NewPageDC(DM: PDevMode);
 

  1. Добавьте следующую процедуру в секцию реализации NewPrint.pas:

 procedure TPrinter.NewPageDC(DM: PDevMode);
 begin
   CheckPrinting(True);
   EndPage(DC);
   {Проверяем наличие новых установок для принтера}
   if Assigned(DM) then
     ResetDC(DC,DM^);
   StartPage(DC);
   Inc(FPageNumber);
   Canvas.Refresh;
 end;
 

  1. Вместо добавления "Printers" в секцию USES вашего приложения (список используемых модулей), добавьте "NewPrint".

Теперь вдобавок к старым методам (таким как BeginDoc, EndDoc, NewPage и др.), у вас появилась возможность изменения свойств принтера "на лету", т.е. между страницами при печати одного и того же документа. (Пример приведен ниже.)

Вместо вызова:


 Printer.NewPage;
 

напишите:


 Printer.NewPageDC(DevMode);
 

Вот небольшой пример:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   ADevice, ADriver, APort: array[0..255] of char;
   ADeviceMode: THandle;
   DevMode: PDevMode;
 begin
   with Printer do
   begin
     GetPrinter(ADevice, ADriver, APort, ADeviceMode);
     SetPrinter(ADevice, ADriver, APort, 0);
     GetPrinter(ADevice, ADriver, APort, ADeviceMode);
     DevMode := GlobalLock(ADeviceMode);
     if not Assigned(DevMode) then
       ShowMessage('Не могу установить принтер.')
     else
     begin
       with DevMode^ do
       begin
         {Применяем здесь любые настройки, необходимые для изменения установок печати}
         dmDefaultSource := DMBIN_UPPER;
         {этот код приведен в "Windows.pas"}
       end;
       GlobalUnlock(ADeviceMode);
       SetPrinter(ADevice, ADriver, APort, ADeviceMode);
     end;
   end;
 
   Printer.BeginDoc;
   Printer.Canvas.TextOut(50, 50, 'Эта страница печатается из ВЕРХНЕГО ЛОТКА.');
 
   with DevMode^ do
   begin
     {Применяем здесь любые настройки, необходимые для изменения установок печати}
     dmDefaultSource := DMBIN_LOWER;
     {этот код приведен в "Windows.pas"}
   end;
 
   Printer.NewPageDC(DevMode);
 
   Printer.Canvas.TextOut(50, 50, 'Эта страница печатается из НИЖНЕГО ЛОТКА.');
   Printer.EndDoc;
 end;
 
 {*************************************************************
 
 Примечание от автора:
 
 Я использовал это во многих своих программах, поэтому я уверен в работоспособности кода.
 
 Данный кода был создан в Delphi Client/Server 2.01 под WinNT 4.0, но впоследствии был
 проверен на других версиях Delphi, а также под Windows95.
 Правда я еще не поробовал его под Delphi 4... Если вы имеете любые комментарии или улучшения,
 не постесняйтесь отправить их мне...
 
 ************************************************************}
 




Как изменить стандартный цвет ProgressBar

Самый простой способ, это изменить цветовую схему в свойствах экрана...

А вот при помощи следующей команды можно разукрасить ProgressBar не изменяя системных настроек:


 PostMessage(ProgressBar1.Handle, $0409, 0, clGreen);
 

Вуаля! Теперь Progress Bar зелёный. Это всего лишь простой пример чёрной магии ;)




Как изменить стандартный цвет ProgressBar 2


 uses
   CommCtrl;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   // Set the Background color to teal 
   Progressbar1.Brush.Color := clTeal;
   // Set bar color to yellow 
   SendMessage(ProgressBar1.Handle, PBM_SETBARCOLOR, 0, clYellow);
 end;
 




Переключение принтеров при печати в QuickReport

Привет! Кто-нибудь пристально изучал объект TPrinter? Вы можете задать необходимый для печати принтер, используя свойство Printer.PrinterIndex. Для примера:


 // Устанавливает первый принтер, проинсталлированный в системе
 Printer.PrinterIndex:=0;
 // Указывает на принтер, установленный в системе по умолчанию
 Printer.PrinterIndex:=-1;
 

И все! Не нужно никаких Win API функций и глобальных переменных!




Как изменить стиль шрифта RichEdit нажатиями соответствующих клавиш (например включить курсив по нажатию Ctrl+I)

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

В примере стили шрифта меняются по нажатию след. комбинаций клавиш:

Ctrl + B
вкл/выкл жирного шрифта
Ctrl + I
вкл/выкл наклонного шрифта
Ctrl + S
вкл/выкл зачеркнутого шрифта
Ctrl + U
вкл/выкл подчеркнутого шрифта

 const
   KEY_CTRL_B = 02;
   KEY_CTRL_I = 9;
   KEY_CTRL_S = 19;
   KEY_CTRL_U = 21;
 
 procedure TForm1.RichEdit1KeyPress(Sender: TObject; var Key: Char);
 begin
   case Ord(Key) of
     KEY_CTRL_B:
       begin
         Key := #0;
         if fsBold in (Sender as TRichEdit).SelAttributes.Style then
           (Sender as TRichEdit).SelAttributes.Style :=
           (Sender as TRichEdit).SelAttributes.Style - [fsBold]
         else
           (Sender as TRichEdit).SelAttributes.Style :=
           (Sender as TRichEdit).SelAttributes.Style + [fsBold];
       end;
     KEY_CTRL_I:
       begin
         Key := #0;
         if fsItalic in (Sender as TRichEdit).SelAttributes.Style then
           (Sender as TRichEdit).SelAttributes.Style :=
           (Sender as TRichEdit).SelAttributes.Style - [fsItalic]
         else
           (Sender as TRichEdit).SelAttributes.Style :=
           (Sender as TRichEdit).SelAttributes.Style + [fsItalic];
       end;
     KEY_CTRL_S:
       begin
         Key := #0;
         if fsStrikeout in (Sender as TRichEdit).SelAttributes.Style then
           (Sender as TRichEdit).SelAttributes.Style :=
           (Sender as TRichEdit).SelAttributes.Style-[fsStrikeout]
         else
           (Sender as TRichEdit).SelAttributes.Style :=
           (Sender as TRichEdit).SelAttributes.Style+[fsStrikeout];
       end;
     KEY_CTRL_U:
       begin
         Key := #0;
         if fsUnderline in (Sender as TRichEdit).SelAttributes.Style then
           (Sender as TRichEdit).SelAttributes.Style :=
           (Sender as TRichEdit).SelAttributes.Style-[fsUnderline]
         else
           (Sender as TRichEdit).SelAttributes.Style :=
           (Sender as TRichEdit).SelAttributes.Style+[fsUnderline];
       end;
   end;
 end;
 




Как изменить цвет отмеченных записей в DBGrid


Сидят два пьяных интернетчика вечером на скамейке, после посещения интернет-кафе. Первый второму:
- Привет, как дела двоеточие, две закрывающих скобки.
Второй долго ищет перед собой клаву, потом, подумав говорит:
- Нормально, а у тя?
Смотрит, а первый уже лежит в дауне под скамейкой.. :( Второй, еще подумав, добавляет:
- Сенд тсру сервер!

Например, так:


 DefaultDrawing := False;
 ...
 
 procedure TfrmCard.GridDrawColumnCell(Sender: TObject; const Rect: TRect;
 DataCol: Integer; Column: TColumn; State: TGridDrawState);
 var
   index: Integer;
   Marked, Selected: Boolean;
 begin
   Marked := False;
   if (dgMultiSelect in Grid.Options) and (THackDBGrid(Grid).Datalink.Active) then
     Marked := Grid.SelectedRows.Find(THackDBGrid(Grid).Datalink.Datasource.Dataset.Bookmark, index);
   Selected := (THackDBGrid(Grid).Datalink.Active) and (Grid.Row-1 = THackDBGrid(Grid).Datalink.ActiveRecord);
 
   if Marked then
   begin
     Grid.Canvas.Brush.Color:=$DFEFDF;;
     Grid.Canvas.Font.Color :=clBlack;
   end;
 
   if Selected then
   begin
     Grid.Canvas.Brush.Color:=$FFFBF0;
     Grid.Canvas.Font.Color :=clBlack;
     if Marked then
       Grid.Canvas.Brush.Color:=$EFE3DF; { $8F8A30 }
   end;
   Grid.DefaultDrawColumnCell(Rect, DataCol, Column, State);
 end;
 

где:


 THackDBGrid = class(TDBGrid)
   property DataLink;
   property UpdateLock;
 end;
 




Изменить громкость


Билл Гейтс очень любил музыку Джимми Моррисона и его команды. Ему до смерти хотелось придумать что-нибудь свое, такое же: серьезное и ответственное. Правда вот фантазии маловато у него было, не хватило децл...

Эта программа увеличивает громкость выбранного канала на 1000:


 uses MMSystem;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   vol: longint;
   LVol, RVol: integer;
 begin
   AuxGetVolume(ListBox1.ItemIndex, @Vol);
   LVol := Vol shr 16;
   if LVol < MaxWord - 1000 then
     LVol := LVol + 1000
   else
     LVol := MaxWord;
   RVol := (Vol shl 16) shr 16;
   if RVol < MaxWord - 1000 then
     RVol := RVol + 1000
   else
     RVol := MaxWord;
   AuxSetVolume(ListBox1.ItemIndex, LVol shl 16 + RVol);
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   i: integer;
   cap: TAuxCaps;
 begin
   for i := 0 to auxGetNumDevs - 1 do
   begin
     auxGetDevCaps(i, Addr(cap), SizeOf(cap));
     ListBox1.Items.Add(cap.szPname)
   end;
 end;
 




Изменить громкость 2


 procedure SetVolume(X: Word);
 var
   iErr: Integer;
   i: integer;
   a: TAuxCaps;
 begin
   for i := 0 to auxGetNumDevs do
   begin
     auxGetDevCaps(i, Addr(a), SizeOf(a));
     if a.wTechnology = AUXCAPS_CDAUDIO then
       break;
   end;
 
   // Устанавливаем одинаковую громкость для левого и правого каналов.
   // VOLUME := LEFT*$10000 + RIGHT*1
 
   iErr := auxSetVolume(i, (X * $10001));
   if (iErr‹›0) then
     ShowMessage('No audio devices are available!');
 end;
 
 function GetVolume: Word;
 var
   iErr: Integer;
   i: integer;
   a: TAuxCaps;
   vol: word;
 begin
   for i := 0 to auxGetNumDevs do
   begin
     auxGetDevCaps(i, Addr(a), SizeOf(a));
     if a.wTechnology = AUXCAPS_CDAUDIO then
       break;
   end;
   iErr := auxGetVolume(i, addr(vol));
   GetVolume := vol;
   if (iErr‹›0) then
     ShowMessage('No audio devices are available!');
 end;
 




Как программно изменять громкость звука


 unit Volumes;
 
 interface
 
 uses
   Windows, Messages, Classes, ExtCtrls, ComCtrls, MMSystem;
 
 const
   CDVolume       = 0;
   WaveVolume     = 1;
   MidiVolume     = 2;
 
 type
   TVolumeControl = class(TComponent)
   private
     FDevices     : array[0..2] of Integer;
     FTrackBars   : array[0..2] of TTrackBar;
     FTimer       : TTimer;
     function       GetInterval: Integer;
     procedure      SetInterval(AInterval: Integer);
     function       GetVolume(AIndex: Integer): Byte;
     procedure      SetVolume(AIndex: Integer; aVolume: Byte);
     procedure      InitVolume;
     procedure      SetTrackBar(AIndex: Integer; ATrackBar: TTrackBar);
     { Private declarations }
     procedure      Update(Sender: TObject);
     procedure      Changed(Sender: TObject);
   protected
     { Protected declarations }
     procedure      Notification(AComponent: TComponent; AOperation:
 TOperation); override;
   public
     { Public declarations }
     constructor    Create(AOwner: TComponent); override;
     destructor     Destroy; override;
   published
     { Published declarations }
     property       Interval: Integer read GetInterval write SetInterval default
 500;
     property       CDVolume: Byte index 0 read GetVolume write SetVolume stored
 False;
     property       CDTrackBar: TTrackBar index 0 read FTrackBars[0] write
 SetTrackBar;
     property       WaveVolume: Byte index 1 read GetVolume write SetVolume
 stored False;
     property       WaveTrackBar: TTrackBar index 1 read FTrackBars[1] write
 SetTrackBar;
     property       MidiVolume: Byte index 2 read GetVolume write SetVolume
 stored False;
     property       MidiTrackBar: TTrackBar index 2 read FTrackBars[2] write
 SetTrackBar;
   end;
 
 procedure Register;
 
 implementation
 
 procedure Register;
 begin
   RegisterComponents('Any', [TVolumeControl]);
 end;
 
 type
     TVolumeRec = record
     case Integer of
     0: (LongVolume: Longint);
     1: (LeftVolume,
         RightVolume : Word);
     end;
 
     function       TVolumeControl.GetInterval: Integer;
     begin
       Result := FTimer.Interval;
     end;
 
     procedure      TVolumeControl.SetInterval(AInterval: Integer);
     begin
       FTimer.Interval := AInterval;
     end;
 
     function       TVolumeControl.GetVolume(AIndex: Integer): Byte;
     var Vol: TVolumeRec;
     begin
       Vol.LongVolume := 0;
       if FDevices[AIndex] < >  -1 then
       case AIndex of
       0: auxGetVolume(FDevices[AIndex], @Vol.LongVolume);
       1: waveOutGetVolume(FDevices[AIndex], @Vol.LongVolume);
       2: midiOutGetVolume(FDevices[AIndex], @Vol.LongVolume);
       end;
       Result := (Vol.LeftVolume + Vol.RightVolume) shr 9;
     end;
 
     procedure      TVolumeControl.SetVolume(aIndex: Integer; aVolume: Byte);
     var Vol: TVolumeRec;
     begin
       if FDevices[AIndex] < >  -1 then
       begin
         Vol.LeftVolume := aVolume shl 8;
         Vol.RightVolume := Vol.LeftVolume;
         case AIndex of
         0: auxSetVolume(FDevices[AIndex], Vol.LongVolume);
         1: waveOutSetVolume(FDevices[AIndex], Vol.LongVolume);
         2: midiOutSetVolume(FDevices[AIndex], Vol.LongVolume);
         end;
       end;
     end;
 
     procedure      TVolumeControl.SetTrackBar(AIndex: Integer; ATrackBar:
 TTrackBar);
     begin
       if ATrackBar < >  FTrackBars[AIndex] then
       begin
         FTrackBars[AIndex] := ATrackBar;
         Update(Self);
       end;
     end;
 
  AOperation: TOperation);
     var I: Integer;
     begin
       inherited Notification(AComponent, AOperation);
       if (AOperation = opRemove) then
       for I := 0 to 2 do if (AComponent = FTrackBars[I])
       then FTrackBars[I] := Nil;
     end;
 
     procedure      TVolumeControl.Update(Sender: TObject);
     var I: Integer;
     begin
       for I := 0 to 2 do
       if Assigned(FTrackBars[I]) then
       with FTrackBars[I] do
       begin
         Min := 0;
         Max := 255;
         if Orientation = trVertical
         then Position := 255 - GetVolume(I)
         else Position := GetVolume(I);
         OnChange := Self.Changed;
       end;
     end;
 
     constructor    TVolumeControl.Create(AOwner: TComponent);
     begin
       inherited Create(AOwner);
       FTimer := TTimer.Create(Self);
       FTimer.OnTimer := Update;
       FTimer.Interval := 500;
       InitVolume;
     end;
 
     destructor     TVolumeControl.Destroy;
     var I: Integer;
     begin
       FTimer.Free;
       for I := 0 to 2 do
       if Assigned(FTrackBars[I]) then
       FTrackBars[I].OnChange := Nil;
       inherited Destroy;
     end;
 
     procedure      TVolumeControl.Changed(Sender: TObject);
     var I: Integer;
     begin
       for I := 0 to 2 do
       if Sender = FTrackBars[I] then
       with FTrackBars[I] do
       begin
         if Orientation = trVertical
         then SetVolume(I, 255 - Position)
         else SetVolume(I, Position);
       end;
     end;
 
     procedure      TVolumeControl.InitVolume;
     var AuxCaps     : TAuxCaps;
         WaveOutCaps : TWaveOutCaps;
         MidiOutCaps : TMidiOutCaps;
         I,J         : Integer;
     begin
       FDevices[0] := -1;
       for I := 0 to auxGetNumDevs - 1 do
       begin
         auxGetDevCaps(I, @AuxCaps, SizeOf(AuxCaps));
         if (AuxCaps.dwSupport and AUXCAPS_VOLUME) < >  0 then
         begin
           FTimer.Enabled := True;
           FDevices[0] := I;
           break;
         end;
       end;
       FDevices[1] := -1;
       for I := 0 to waveOutGetNumDevs - 1 do
       begin
         waveOutGetDevCaps(I, @WaveOutCaps, SizeOf(WaveOutCaps));
         if (WaveOutCaps.dwSupport and WAVECAPS_VOLUME) < >  0 then
         begin
           FTimer.Enabled := True;
           FDevices[1] := I;
           break;
         end;
       end;
       FDevices[2] := -1;
       for I := 0 to midiOutGetNumDevs - 1 do
       begin
         MidiOutGetDevCaps(I, @MidiOutCaps, SizeOf(MidiOutCaps));
         if (MidiOutCaps.dwSupport and MIDICAPS_VOLUME) < >  0 then
         begin
           FTimer.Enabled := True;
           FDevices[2] := I;
           break;
         end;
       end;
     end;
 
 end.
 




Как программно изменять громкость звука 2

Автор: Olookin

А мне дpужбан пpитащил видеокассету с каким-то супеpновым фильмом. Сижу, тупо посмотpел на название с каpтинкой, а потом пеpевеpнул и давай искать системные тpебования с мыслью: "А вдpуг не пойдет?"

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


 procedure TForm1.TrackBar1Change(Sender: TObject);
 var
  s: dword;
  a,b: word;
  h: hWnd;
 begin
  a:=trackbar1.position;
  b:=trackbar2.position;
  s:=(a shl 16) or b;
  waveOutSetVolume(h,s);
 end;
 

свойство Max в каждом TrackBar'e должно равняться 65535 (то есть MaxWord)




Как изменить заголовок кнопки ПУСК

Об активизации продуктов Microsoft. Сообщение Windows 2005: Вы нажали на кнопку "Пуск", для активизации нажатия на кнопку заполните регистрационную форму и вышлите Нам. Через определенное время Вам будет выслан код активизации данного действия.

Для начала создайте какой-нибудь Bitmap, который вы будете натягивать на кнопку [т.к. такого понятия как "заголовок кнопки ПУСК" в действительности не существует], а та надпись, что находится на стартовой кнопке, является рисунком. Создавая рисунок, учитывайте размеры и то, что левая сторона должна быть "плоской", как у нас на рисунке слева, это связано с особенностями наложения.

Далее займёмся проектом. Сначала объявляем глобальные переменные


 StartButton: hWnd;
 OldBitmap: THandle;
 NewImage: TPicture;
 

Затем описываем событие по создания окна [OnCreate]:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   NewImage := TPicture.create;
   NewImage.LoadFromFile('C:\Windows\delphi.BMP'); //здесь укажите путь к нужному файлу
   StartButton := FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil);
   OldBitmap := SendMessage(StartButton, BM_SetImage, 0, NewImage.Bitmap.Handle);
 end;
 

Если вы делаете это на своей машине, то можете всё восстанавливать по событию OnDestroy:


 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   SendMessage(StartButton, BM_SetImage, 0, OldBitmap);
   NewImage.Free;
 end;
 




Изменить системное меню

Многие, наверное, уже задумывались над тем, как же внести изменения в системное меню. На примере вы видите, что кнопка закрытия окна неактивна. К тому же команда "Закрыть" вообще отсутствует в системном меню. Системное меню вызывается по щелчку на иконке окна или Alt+Space.

Если вы напишите следующий код на создание окна (событие OnCreate), то сможете сами в этом убедиться.


 procedure TForm1.FormCreate(Sender: TObject);
 var
   hMenuHandle: HMENU;
 begin
   hMenuHandle := GetSystemMenu(Handle, false);
   if hMenuHandle <> 0 then
     DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
 end;
 

Объявляем переменную типа HMENU. Получаем дескриптор своего системного меню и помещаем его в переменную:

Получить дескриптор позволяет функция GetSystemMenu(). Ей в качестве параметра указываем ключевое слово Handle - оно указывает, что будет получен дескриптор нашего системного меню. Второй параметр, равный false, означает, что возвращаемое функцией значение будет не нулевое, а равное дескриптору меню окна.

Функция DeleteMenu позволяет удалить пункт меню. Сначала ей указываем дескриптор меню - hMenuHandle, затем (SC_CLOSE) значение, идентифицирующее пункт меню, которое может принимать следующие значания:

sc_close
"Закрыть",
sc_move
"Переместить",
sc_size
"Размер",
sc_minimize
"Свернуть",
sc_maximize
"Развернуть"

Последний параметр (MF_BYCOMMAND) означает, что предыдущий параметр дает идентификатор пункта меню. Если бы предыдущий параметр указывал на положение пункта меню, отсчитываемое от нуля, тогда бы мы написали MF_BYPOSITION.

Вот теперь вы можете смело менять наличие и активность того или иного пункта системного меню! Плюс к тому, если вы заботитесь о наличии и активности кнопок на заголовочной полосе, соответствующих пунктам меню, то можете поэкспериментировать со свойствами окна BorderStyle & BorderIcons.




Изменить свойства системы


Нынешние системные администраторы - всего лишь беспомощная детвора по сравнению с Администратором Системы И. В. Сталиным.

Когда вы вызываете контекстное меню на иконке "Моего компьютера" и щёлкаете на команде "Свойства" - вы видите свойства системы. Эта статья позволит вам внести туда любой свой собственный текст и даже поместить рисунок!

Для начала давайте заглянем в папку System, находящуюся в директории Windows и найдём там файл инициализации с именем Oeminfo.ini, нужно его отредактировать так, чтобы он выглядел следующим образом:


 [General]
 Manufacturer="Производитель M$"
 Model="Модель, чёта, типа, 9x"
 
 [Support Information]
 Line1="Поддержка: Delphi World ©"
 Line2="Всё это написано из Delphi!"
 Line3="...а Бил ГЕЙ, тс..."
 

Здесь, как видно, должно быть всего два раздела:

[General]
Указанные здесь данные будут отображаться в окне "Свойства: Система" на закладке "Общие".
[Support Information]
Информация о поддержки, которая будет видна в диалоговом окне появляющимся по нажатию на кнопке "Поддержка..." на той же закладке.

В разделе [General] есть два параметра (Manufacturer и Model), которым можно задавать любые значения.

В разделе же информации о поддержки можно создать сколько угодно параметров.

Чтобы было ещё эффектнее можно поместить в окно свойств системы даже графический файл, для этого файл нужно сначала создать, используя любой графический редактор, учитывая главное условие - размер файла должен быть 127х127. Назвать файл нужно так: Oemlogo.bmp, а затем поместить в папку System, находящуюся в директории Windows.

Ну, а как же занести информацию в ini-файл программно?

Для взаимодействия с ini-файлами нужно сделать следующее:

  • Сначала в области uses нужно объявить модуль inifiles
  • Затем объявить переменную класса TIniFile
  • Выделить память под этот объект, т.е. создать его с помощью метода Create
  • А после уже можно заносить или считывать данные из этого ini-файла

Вид модуля должен быть примерно таким:


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   inifiles; {Объявляем модуль для взаимодействия с ini-файлами}
 
 type
   TForm1 = class(TForm)
     procedure FormCreate(Sender: TObject);
     private
       { Private declarations }
     public
       { Public declarations }
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 {по созданию окна пишем следующий код}
 procedure TForm1.FormCreate(Sender: TObject);
 var
   APChar: array [0..254] of char; {сначала нужно узнать где у пользователя папка Windows - объявляем под это дело массив символов}
   sFile: string; {объявляем текстовую переменную под имя ini-файла}
   Ini: TIniFile; {и экземпляр класса TIniFile для взаимодействия с файлами инициализации}
 begin
   GetWindowsDirectory(APChar, 255); {узнаём, где у чудилки находится каталог Windows}
   sFile := string(APChar) + '\System\Oeminfo.ini'; {в текстовую переменную помещаем имя нужного нам файла}
   if FileExists(sFile) then {и если файл существует...}
   begin
     Ini := TIniFile.Create(sFile); {связываем объявленную переменную с этим файлом}
     {далее заносим данные, используя процедуру WriteString, т.к. данные текстового типа.
     Параметры у процедуры такие: Имя раздела, Имя ключа, Вносимое значение}
 
     Ini.WriteString('General','Manufacturer','"Производитель M$"');
     Ini.WriteString('General','Model','"Модель, чёта, типа, 9x"');
     Ini.WriteString('Support Information','Line1','"Поддержка: Delphi World ©"');
     Ini.WriteString('Support Information','Line2','"Всё это написано из Delphi!"');
     Ini.WriteString('Support Information','Line3','"...а Бил ГЕЙ, тс..."');
     Ini.Free; {ну, а под конец, сделав своё грязное дело, мы как порядочные... программисты - освобождаем занимаемую память}
   end;
 end;
 
 end.
 




Как сменить системное время в операционной системе из программы


 //****************************************
 // Функция (раздел Public) SetPCSystemTime
 // изменяет системную дату и время.
 // Параметр(ы) : tDati Новые дата и время
 // Возвращаемые значения: True - успешное завершение
 // False - метод несработал
 //****************************************
 function SetPCSystemTime(tDati: TDateTime): Boolean;
 var
   tSetDati: TDateTime;
   vDatiBias: Variant;
   tTZI: TTimeZoneInformation;
   tST: TSystemTime;
 begin
   GetTimeZoneInformation(tTZI);
   vDatiBias := tTZI.Bias / 1440;
   tSetDati := tDati + vDatiBias;
   with tST do
   begin
     wYear := StrToInt(FormatDateTime('yyyy', tSetDati));
     wMonth := StrToInt(FormatDateTime('mm', tSetDati));
     wDay := StrToInt(FormatDateTime('dd', tSetDati));
     wHour := StrToInt(FormatDateTime('hh', tSetDati));
     wMinute := StrToInt(FormatDateTime('nn', tSetDati));
     wSecond := StrToInt(FormatDateTime('ss', tSetDati));
     wMilliseconds := 0;
   end;
   SetPCSystemTime := SetSystemTime(tST);
 end;
 




Как сменить системное время в операционной системе из программы 2


 function SetTime(DateTime:TDateTime): boolean;
 var
   st: TSystemTime;
   ZoneTime: TTimeZoneInformation;
 begin
   GetTimeZoneInformation(ZoneTime);
   DateTime:=DateTime+ZoneTime.Bias/1440;
   with st do
   begin
     DecodeDate(DateTime, wYear, wMonth, wDay);
     DecodeTime(DateTime, wHour, wMinute, wSecond, wMilliseconds);
   end;
   Result:=SetSystemTime(st);
 end;
 




Изменение величины табуляции в Memo

- Какая разница между Богом и Биллом Гейтсом?
- Бог не думает, что он Гейтс.

Для этого надо послать сообщение EM_SetTabStops компоненте TMemo, в котором необходимо указать два параметра. Количество передаваемых значений и величины табуляций.

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


 {Установка одной величины табуляции}
 const
   TabInc: LongInt = 40;
 
 begin
   SendMessage(Memo1.Handle, EM_SetTabStops, 1, Longint(@TabInc));
 end;
 
 ...
 
 {Установка двух величин табуляции}
 const
   TabInc: array [1..2] of LongInt = (10, 30);
 
 begin
   SendMessage(Memo1.Handle, EM_SetTabStops, 2, Longint(@TabInc));
 end;
 




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

Автор: Олег Кулабухов


 procedure TForm1.Button1Click(Sender: TObject);
 var
   OldTextColor: TColorRef;
   OldBkColor: TColorRef;
   OldBkMode: Integer;
 begin
   OldTextColor := SetTextColor(Form1.Canvas.Handle, clYellow);
   OldBkColor := SetBkColor(Form1.Canvas.Handle, clGreen);
   OldBkMode := SetBkMode(Form1.Canvas.Handle, OPAQUE);
   TextOut(Form1.Canvas.Handle, 20, 20, 'Delphi World - лучше всех! ;-)', 27);
   SetBkMode(Form1.Canvas.Handle, OldBkMode);
   SetBkColor(Form1.Canvas.Handle, OldBkColor);
   SetTextColor(Form1.Canvas.Handle, OldTextColor);
 end;
 




Изменение регистра

В Delphi есть три функции для изменения регистра: upcase, lowercase, uppercase. Но они работают только для латинского алфавита. Чтобы сделать аналогичные функции для русского алфавита я использовал то, что в кодировке Windows-1251 буквы расставлены по алфавиту, как большие, так и маленькие. То есть номер большой буквы связан с номером маленькой константой. И в русском, и в английском алфавитах маленькие буквы находятся за большими с разностью в 32 символа.

Здесь реализованы четыре функции: upcase и locase для изменения регистра одного символа, и uppercase и lowercase для изменения регистра строки


 function UpCase(ch: char): char;
 begin
   if (ch in ['a'..'z', 'а'..'я']) then
     result := chr(ord(ch) - 32)
   else
     result := ch;
 end;
 
 function LoCase(ch: char): char;
 begin
   if (ch in ['A'..'Z', 'А'..'Я']) then
     result := chr(ord(ch) + 32)
   else
     result := ch;
 end;
 
 function UpperCase(s: string): string;
 var
   i: integer;
 begin
   result := s;
   for i := 1 to length(result) do
     if (result[i] in ['a'..'z', 'а'..'я']) then
       result[i] := chr(ord(result[i]) - 32);
 end;
 
 function LowerCase(s: string): string;
 var
   i: integer;
 begin
   result := s;
   for i := 1 to length(result) do
     if (result[i] in ['A'..'Z', 'А'..'Я']) then
       result[i] := chr(ord(result[i]) + 32);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 const
   s = 'zZцЦ.';
 var
   i: integer;
 begin
   Form1.Caption := 'DownCase: ';
   for i := 1 to Length(s) do
     Form1.Caption := Form1.Caption + LoCase(s[i]);
   Form1.Caption := Form1.Caption + ' UpCase: ';
   for i := 1 to Length(s) do
     Form1.Caption := Form1.Caption + UpCase(s[i]);
   Form1.Caption := Form1.Caption + ' UpperCase: ' + UpperCase(s);
   Form1.Caption := Form1.Caption + ' LowerCase: ' + LowerCase(s);
 end;
 




Изменяем цвет TPageControl


 type
   TTabSheet = class(ComCtrls.TTabSheet)
   private
     FColor: TColor;
     procedure SetColor(Value: TColor);
     procedure WMEraseBkGnd(var Msg: TWMEraseBkGnd);
       message WM_ERASEBKGND;
   public
     constructor Create(aOwner: TComponent); override;
     property Color: TColor read FColor write SetColor;
   end;
 
   {...}
  implementation
 {...}
 
 constructor TTabSheet.Create(aOwner: TComponent);
 begin
   inherited;
   FColor := clBtnFace;
 end;
 
 procedure TTabSheet.SetColor(Value: TColor);
 begin
   if FColor  Value then
   begin
     FColor := Value;
     Invalidate;
   end;
 end;
 
 procedure TTabSheet.WMEraseBkGnd(var Msg: TWMEraseBkGnd);
 begin
   if FColor = clBtnFace then
     inherited
   else
   begin
     Brush.Color := FColor;
     Windows.FillRect(Msg.dc, ClientRect, Brush.Handle);
     Msg.Result := 1;
   end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Tabsheet1.Color := clWhite;
   TabSheet2.Color := clLime;
 end;
 
 // PageControl1.OwnerDraw := true ! 
 
 procedure TForm1.PageControl1DrawTab(Control: TCustomTabControl;
   TabIndex: Integer; const Rect: TRect; Active: Boolean);
 var
   AText: string;
   APoint: TPoint;
 begin
   with (Control as TPageControl).Canvas do
   begin
     Brush.Color := clred;
     FillRect(Rect);
     AText := TPageControl(Control).Pages[TabIndex].Caption;
     with Control.Canvas do
     begin
       APoint.x := (Rect.Right - Rect.Left) div 2 - TextWidth(AText) div 2;
       APoint.y := (Rect.Bottom - Rect.Top) div 2 - TextHeight(AText) div 2;
       TextRect(Rect, Rect.Left + APoint.x, Rect.Top + APoint.y, AText);
     end;
   end;
 end;
 




Как реализовать регулятор громкости

Автор: Nomadic

Да всё пpосто. Даже, я бы сказал, тyпо. :-)


 INT GetMasterVolumeControlID()
 {
   // get dwLineID
   MIXERLINE mxl;
   mxl.cbStruct = sizeof(MIXERLINE);
   mxl.dwComponentType = MIXERLINE_COMPONENTTYPE_DST_SPEAKERS;
   if (::mixerGetLineInfo((HMIXEROBJ)ghmx, &mxl,
     MIXER_OBJECTF_HMIXER | MIXER_GETLINEINFOF_COMPONENTTYPE)
     != MMSYSERR_NOERROR)
     return 34;
   // get dwControlID
   MIXERCONTROL mxc;
   MIXERLINECONTROLS mxlc;
   mxlc.cbStruct = sizeof(MIXERLINECONTROLS);
   mxlc.dwLineID = mxl.dwLineID;
   mxlc.dwControlType = MIXERCONTROL_CONTROLTYPE_VOLUME;
   mxlc.cControls = 1;
   mxlc.cbmxctrl = sizeof(MIXERCONTROL);
   mxlc.pamxctrl = &mxc;
   if (::mixerGetLineControls((HMIXEROBJ)ghmx, &mxlc,
     MIXER_OBJECTF_HMIXER | MIXER_GETLINECONTROLSF_ONEBYTYPE)
     != MMSYSERR_NOERROR)
     return 34;
   return mxc.dwControlID;
 }
 
  BOOL SetMasterVolume(DWORD dwVolume)
  {
    MIXERCONTROLDETAILS mxcd;
    MIXERCONTROLDETAILS_UNSIGNED mxcd_u;
    mxcd.cbStruct = sizeof(mxcd);
    mxcd.dwControlID = MasterVolumeControlID;
    mxcd.cChannels = 1;
    mxcd.cMultipleItems = 0;
    mxcd.cbDetails = 4;
    mxcd.paDetails = &mxcd_u;
    mmr = mixerGetControlDetails((HMIXEROBJ)ghmx, &mxcd, 0L);
    if (MMSYSERR_NOERROR != mmr) return FALSE;
    mxcd_u.dwValue = dwVolume;
    mmr = mixerSetControlDetails((HMIXEROBJ)ghmx, &mxcd, 0L);
    if (MMSYSERR_NOERROR != mmr) return FALSE;
    return TRUE;
  }
 

Переписывать на Delphi, думаю, ни к чему. Надо лишь не забыть добавить uses MMSystem; Громкость отдельных каналов очень просто устанавливается через auxSetVolume и аналогичные.




Как программно заменить обои на рабочем столе

Автор: Igor Nikolaev aKa The Sprite

Дилетантские разговоры о компьютерах вызывают резкую тошноту влоть до приступов рвоты. Вопрос о том как поменять "обои" в Windows вызывает желание перерезать горло вопрошающему.


 program wallpapr;
 uses Registry, WinProcs;
 
 procedure SetWallpaper(sWallpaperBMPPath: string; bTile: boolean);
 var
 
   reg: TRegIniFile;
 begin
   //     Изменяем ключи реестра
   //     HKEY_CURRENT_USER
   //     Control Panel\Desktop
   //     TileWallpaper (REG_SZ)
   //     Wallpaper (REG_SZ)
 
   reg := TRegIniFile.Create('Control Panel\Desktop');
   with reg do
   begin
     WriteString('', 'Wallpaper',
       sWallpaperBMPPath);
     if (bTile) then
     begin
       WriteString('', 'TileWallpaper', '1');
     end
     else
     begin
       WriteString('', 'TileWallpaper', '0');
     end;
   end;
   reg.Free;
   // Оповещаем всех о том, что мы изменили системные настройки
   SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil,
 
     {Эта строка - продолжение предыдущей} SPIF_SENDWININICHANGE);
 end;
 
 // пример установки WallPaper по центру рабочего стола
 SetWallpaper('c:\winnt\winnt.bmp', False);
 //Эту строчку надо написать где-то в программе.
 




Как программно заменить обои на рабочем столе 2

Автор: Владимир Рыбант

Другие подобные советы не изменяют обои, если в Windows работает режим Active Desktop

Нужно использовать следующее:


 uses
   ComObj, ShlObj;
 
 procedure ChangeActiveWallpaper;
 const
   CLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}';
 var
   ActiveDesktop: IActiveDesktop;
 begin
   ActiveDesktop := CreateComObject(CLSID_ActiveDesktop)
     as IActiveDesktop;
   ActiveDesktop.SetWallpaper('c:\windows\forest.bmp', 0);
   ActiveDesktop.ApplyChanges(AD_APPLY_ALL or AD_APPLY_FORCE);
 end;
 

Этим способом можно также изменять обои картинками jpg и gif




Как программно заменить обои на рабочем столе 3


 unit Walpaper;
 
 interface
 
 uses
 {$IFDEF WIN32}Windows, Registry, {$ELSE}WinTypes, WinProcs, IniFiles, {$ENDIF}
   Classes, Controls, SysUtils;
 
 type
   TWallPaper = class(TComponent)
   private
     PC: array[0..$FF] of Char;
 {$IFDEF WIN32}
     Reg: TRegistry;
 {$ELSE}
     Reg: TIniFile;
     WinIniPath: string;
 {$ENDIF}
 
     function GetWallpaper: string;
     procedure SetWallpaper(Value: string);
     function GetTile: Boolean;
     procedure SetTile(Value: Boolean);
     function GetStretch: Boolean;
     procedure SetStretch(Value: Boolean);
   protected
 {$IFNDEF WIN32}
     constructor Create(aOwner: TComponent); override;
 {$ENDIF}
   public
   published
     property Wallpaper: string read GetWallpaper write SetWallpaper;
     property Tile: Boolean read GetTile write SetTile;
     property Stretch: Boolean read GetStretch write SetStretch;
   end;
 
 procedure Register;
 
 implementation
 
 {$IFNDEF WIN32}
 
 constructor TWallpaper.Create(aOwner: TComponent);
 begin
   inherited Create(aOwner);
   GetWindowsDirectory(PC, $FF);
   WinIniPath := StrPas(PC) + '\WIN.INI';
 end;
 {$ENDIF}
 
 function TWallpaper.GetWallpaper: string;
 begin
 {$IFDEF WIN32}
   Reg := TRegistry.Create;
   Reg.RootKey := HKEY_CURRENT_USER;
   Reg.OpenKey('\Control Panel\desktop\', False);
   Result := Reg.ReadString('Wallpaper');
   Reg.Free;
 {$ELSE}
   Reg := TIniFile.Create(WinIniPath);
   Result := Reg.ReadString('Desktop', 'Wallpaper', '');
   Reg.Free;
 {$ENDIF}
 end;
 
 procedure TWallpaper.SetWallpaper(Value: string);
 begin
   if not (csDesigning in ComponentState) and
     not (csLoading in ComponentState) and
     not (csReading in ComponentState) then
   begin
     StrPCopy(PC, Value);
     SystemParametersInfo(spi_SetDeskWallpaper, 0, @PC, spif_UpdateIniFile);
   end;
 end;
 
 function TWallpaper.GetTile: Boolean;
 begin
 {$IFDEF WIN32}
   Reg := TRegistry.Create;
   Reg.RootKey := HKEY_CURRENT_USER;
   Reg.OpenKey('\Control Panel\desktop\', False);
   Result := Boolean(StrToInt(Reg.ReadString('TileWallpaper')));
   Reg.Free;
 {$ELSE}
   Reg := TIniFile.Create(WinIniPath);
   Result := Reg.ReadBool('Desktop', 'TileWallpaper', False);
   Reg.Free;
 {$ENDIF}
 end;
 
 procedure TWallpaper.SetTile(Value: Boolean);
 begin
   if not (csDesigning in ComponentState) and
     not (csLoading in ComponentState) and
     not (csReading in ComponentState) then
   begin
 {$IFDEF WIN32}
     Reg := TRegistry.Create;
     Reg.RootKey := HKEY_CURRENT_USER;
     Reg.OpenKey('\Control Panel\desktop\', False);
     Reg.WriteString('TileWallpaper', IntToStr(Integer(Value)));
     Reg.Free;
 {$ELSE}
     Reg := TIniFile.Create(WinIniPath);
     Reg.WriteBool('Desktop', 'TileWallpaper', Value);
     Reg.Free;
 {$ENDIF}
     SetWallpaper(Wallpaper);
   end;
 end;
 
 function TWallpaper.GetStretch: Boolean;
 var
   i: Integer;
 begin
 {$IFDEF WIN32}
   Reg := TRegistry.Create;
   try
     Reg.RootKey := HKEY_CURRENT_USER;
     Reg.OpenKey('\Control Panel\desktop\', False);
     i := StrToInt(Reg.ReadString('WallpaperStyle'));
   except
   end;
   Reg.Free;
 {$ELSE}
   Reg := TIniFile.Create(WinIniPath);
   i := Reg.ReadInteger('Desktop', 'WallpaperStyle', 0);
   Reg.Free;
 {$ENDIF}
   Result := i = 2;
 end;
 
 procedure TWallpaper.SetStretch(Value: Boolean);
 var
   v: Integer;
 begin
   if not (csDesigning in ComponentState) and
     not (csLoading in ComponentState) and
     not (csReading in ComponentState) then
   begin
     if Value then
       v := 2
     else
       v := 0;
 
 {$IFDEF WIN32}
     Reg := TRegistry.Create;
     Reg.RootKey := HKEY_CURRENT_USER;
     Reg.OpenKey('\Control Panel\desktop\', False);
     Reg.WriteString('WallpaperStyle', IntToStr(v));
     Reg.Free;
 {$ELSE}
     Reg := TIniFile.Create(WinIniPath);
     Reg.WriteInteger('Desktop', 'WallpaperStyle', v);
     Reg.Free;
 {$ENDIF}
     SetWallpaper(Wallpaper);
   end;
 end;
 
 procedure Register;
 begin
   RegisterComponents('JohnUtilend;
 
 end.
 Ответ 3:
 WinAPI:
 BOOL SystemParametersInfo(
   UINT uiAction, // system parameter to query or set
   UINT uiParam, // depends on action to be taken
   PVOID pvParam, // depends on action to be taken
   UINT fWinIni // user profile update flag
   );
 
 uiAction := SPI_SETDESKWALLPAPER Sets the desktop wallpaper.
 pvParam := 'Имя BMP файла'#0
 uiParam := 0
 fWinIni := SPIF_UPDATEINIFILE
 




Как программно заменить обои на рабочем столе 4


 procedure TForm1.FormCreate(Sender: TObject);
 var
   St : string;
 begin
   St := 'C:\MyWallPaper.Bmp';
   SystemParametersInfo(SPI_SETDESKWALLPAPER,UINT(St),nil,SPIF_SENDCHANGE);
 end;
 




Как программно заменить обои на рабочем столе 5


 program change;
 uses
   windows;
 var
   s: string;
 begin
   s := paramStr(1);
   SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, @S[1],
     SPIF_UPDATEINIFILE OR SPIF_SENDWININICHANGE);
 end.
 
 // Запускаешь:
 // change.exe "имя файла с картинкой"
 




Изменить оконную процедуру для TForm

Переопределите в подклассе TForm оконную процедуру WinProc класса. В примере оконная процедура переопределяется для того чтобы реагировать на сообщение WM_CANCELMODE, показывающее, что выполняется messagebox или какой-либо еще диалог.


 type
   TForm1 = class(TForm)
   Button1: TButton;
   procedure WndProc (var message: TMessage); override;
   procedure Button1Click(Sender: TObject);
   private
     {Private declarations}
   public
     {Public declarations}
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.WndProc (var message: TMessage);
 begin
   if message.Msg = WM_CANCELMODE then
     Form1.Caption := 'A dialog or message box has popped up'
   else
     inherited // Oстальное сделает родительская процедура
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ShowMessage('Test Message');
 end;
 




Пример CHARTFX

Выходя из здания компании Microsoft, киллеp заметил толпy юзеpов, митингyющих под окнами с плакатами "Bill Gates MustDie". "Hакаpкали" - yсмехнyлся он, вытиpая от кpови большой охотничий нож...

Документация, поставляемая с Delphi, слишком запутанна и тяжела, особенно если вы не пользователь VBX...

Следующий пример устанавливает некоторые значения и пр. для ChartFX:


 {Код получает данные из базы данных и рисует их}
 
 begin
   MyTable.active := True; {открываем базу данных}
   MyTable.first;
   MyChart.title[CHART_BOTTOMTIT] := 'Заголовок по оси X';
   MyChart.title[CHART_LEFTTIT] := 'Заголовок по оси Y';
   MyChart.OpenData[COD_XVALUES] := MakeLong(numOfSeries, numofPoints);
   MyChart.OpenData[COD_VALUES] := MakeLong(numOfSeries, NumofPoints);
   MyChart.ThisSerie := SeriesNum; {начинаем с 0}
   while MyTable.EOF <> True do
   begin
     MyChart.value[i] := MyTable.FieldByName('SOMEFIELD').AsFloat;
     MyChart.Xvalue[i] := MyTable.FieldByName('SOMEOTHERFIELD').AsFloat;
     MyTable.next;
     i := i + 1; {естественно, вам необходимо определить и инициализировать 'i'}
   end;
   MyChart.CloseData[COD_Values] := 0;
   MyChart.CloseData[COD_XValues] := 0;
   MyTable.active := False; {закрываем базу данных}
 end;
 
 {Обратите внимание на то, что данный код отностится к диаграмме
 типа xy scatter. Если вы хотите сменить тип диаграммы ChartFX,
 вам не нужно устанавливать значения для COD_XVALUES}
 




CheckBoxes в StringGrid

Автор: Joel E. Cant

Пример демонстрирует добавление любого количества чекбоксов в StringGrid. В этом примере необходимо добавить TPanel, а в саму панель включить TstringGrid. Так же необходимо добавить невидимый TcheckBox на форму. Затем добавьте 5 колонок и 4 строки в объект StringGrid.


 procedure TForm1.CheckBox1Click(Sender: TObject);
 begin
   ShowMessage('There it is!!');
 end;
 
 // Заполняем заголовок StringGrid
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   StringGrid1.Cells[0, 0] := 'A Simple';
   StringGrid1.Cells[1, 0] := 'Way';
   StringGrid1.Cells[2, 0] := 'To';
   StringGrid1.Cells[3, 0] := 'Do It';
   StringGrid1.Cells[4, 0] := 'Check !!';
 
   AddCheckBoxes; // добавляем чекбоксы...
 end;
 
 procedure TForm1.AddCheckBoxes;
 var
   i: Integer;
   NewCheckBox: TCheckBox;
 begin
   clean_previus_buffer; // очищаем неиспользуемые чекбоксы...
 
   for i := 1 to 4 do
   begin
     StringGrid1.Cells[0, i] := 'a';
     StringGrid1.Cells[1, i] := 'b';
     StringGrid1.Cells[2, i] := 'c';
     StringGrid1.Cells[3, i] := 'd';
 
     NewCheckBox := TCheckBox.Create(Application);
     NewCheckBox.Width := 0;
     NewCheckBox.Visible := false;
     NewCheckBox.Caption := 'OK';
     NewCheckBox.Color := clWindow;
     NewCheckBox.Tag := i;
     NewCheckBox.OnClick := CheckBox1.OnClick; // Связываем предыдущее событие OnClick
                                               // с существующим TCheckBox
     NewCheckBox.Parent := Panel1;
 
     StringGrid1.Objects[4, i] := NewCheckBox;
     StringGrid1.RowCount := i;
   end;
   set_checkbox_alignment; // расположение чекбоксов в ячейках таблицы...
 end;
 
 procedure TForm1.clean_previus_buffer;
 var
   NewCheckBox: TCheckBox;
   i: Integer;
 begin
   for i := 1 to StringGrid1.RowCount do
   begin
     NewCheckBox := (StringGrid1.Objects[4, i] as TCheckBox);
     if NewCheckBox <> nil then
     begin
       NewCheckBox.Visible := false;
       StringGrid1.Objects[4, i] := nil;
     end;
   end;
 end;
 
 procedure TForm1.set_checkbox_alignment;
 var
   NewCheckBox: TCheckBox;
   Rect: TRect;
   i: Integer;
 begin
   for i := 1 to StringGrid1.RowCount do
   begin
     NewCheckBox := (StringGrid1.Objects[4, i] as TCheckBox);
     if NewCheckBox <> nil then
     begin
       Rect := StringGrid1.CellRect(4, i); // получаем размер ячейки для чекбокса
       NewCheckBox.Left := StringGrid1.Left + Rect.Left + 2;
       NewCheckBox.Top := StringGrid1.Top + Rect.Top + 2;
       NewCheckBox.Width := Rect.Right - Rect.Left;
       NewCheckBox.Height := Rect.Bottom - Rect.Top;
       NewCheckBox.Visible := True;
     end;
   end;
 end;
 
 procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
   Rect: TRect; State: TGridDrawState);
 begin
   if not (gdFixed in State) then
     set_checkbox_alignment;
 end;
 




CheckBox в DBGrid


Bpaч дeлaeт oбхoд, гpaдycники y бoльных coбиpaeт, пpoпиcывaeт лeчeниe, пoдхoдит к кoйкe oднoгo бoльнoгo и cпpaшивaeт сecтpy:
- Фaмилия бoльнoгo?
- Bиндoвc, тoлькo ceйчac пocтyпил.
- Имя oтчecтвo?
- Дeвянocтo восемь.
- Бoлeзнь?
- Хpoничecкиe зaвиcaния и cлaбocть yмa. Чeм бyдeм лeчить?
- Mopгoм.


 procedure DrawGridCheckBox(Canvas: TCanvas; Rect: TRect; Checked: boolean);
 var
   DrawFlags: Integer;
 begin
   Canvas.TextRect(Rect, Rect.Left + 1, Rect.Top + 1, ' ');
   DrawFrameControl(Canvas.Handle, Rect, DFC_BUTTON, DFCS_BUTTONPUSH or DFCS_ADJUSTRECT);
   DrawFlags := DFCS_BUTTONCHECK or DFCS_ADJUSTRECT;// DFCS_BUTTONCHECK
   if Checked then
     DrawFlags := DrawFlags or DFCS_CHECKED;
   DrawFrameControl(Canvas.Handle, Rect, DFC_BUTTON, DrawFlags);
 end;
 

На событие OnDrawColumnCell повесьте вызов процедуры DrawGridCheckBox():


 procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
   DataCol: Integer; Column: TColumn; State: TGridDrawState);
 begin
   if Column.FieldName = 'WEIGHT' then // Модифицируйте под себя
     if Column.Field.AsInteger > 10 then
       DrawGridCheckBox(DBGrid1.Canvas, Rect, true)
     else
       DrawGridCheckBox(DBGrid1.Canvas, Rect, false)
 end;
 

Кроме этого, для скрытия текста в ячейках с CheckBox-ом от отображения значения при вводе с клавиатуры определите реакцию на событие OnColumnEnter:


 procedure TfrmMain.DBGrid1ColEnter(Sender: TObject);
 begin
   with TDBGrid(Sender) do
     if SelectedField.FieldName = 'Weight' then // Модифицируйте под себя
       Options := Options - [dgEditing]
     else
       Options := Options + [dgEditing]
 end;
 




CheckBox в StringGrid



 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   Grids, StdCtrls;
 
 type
   TForm1 = class(TForm)
     StringGrid1: TStringGrid;
     procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
       Rect: TRect; State: TGridDrawState);
     procedure FormCreate(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 const
  cell_x = 2;
  cell_y = 2;
 
 var
   Form1: TForm1;
   CheckBox1: TCheckBox;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
   Rect: TRect; State: TGridDrawState);
 var
  r:trect;
 begin
  if(cell_x>=StringGrid1.LeftCol) and
    (cell_x<=StringGrid1.LeftCol+StringGrid1.VisibleColCount) and
    (cell_y>=StringGrid1.TopRow) and
    (cell_x<=StringGrid1.TopRow+StringGrid1.VisibleRowCount) then
      CheckBox1.Visible:=true
  else
      CheckBox1.Visible:=false;
 
  if (acol=cell_x) and (arow=cell_y) then
  begin
    r:=stringgrid1.CellRect(cell_x,cell_y);
    r.Left:=r.left+stringgrid1.left+2;
    r.right:=r.right+stringgrid1.left+2;
    r.top:=r.top+stringgrid1.top+2;
    r.bottom:=r.bottom+stringgrid1.top+2;
    CheckBox1.BoundsRect:=r;
  end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
  CheckBox1:=TCheckBox.Create(form1);
  CheckBox1.parent:=form1;
  CheckBox1.Caption:='proba';
 end;
 
 end.
 




RTL.CheckWin32Version. Функция некорректна

Автор: Дмитрий Померанцев

Только Delphi6 (SP2, возможно и более младшие версии Delphi6). Delphi5 и младше не исследовались, но в них отсутствовали проблемы, связанные с этой функцией. В Delphi7 ошибка исправлена.

Функция


 CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean;
 

предназначена для того, чтобы удостовериться, что версия Windows не меньше указанной. Эта функция используется самой VCL для того, чтобы убедиться в правомерности вызовов API в разных версиях Windows. Во встреченных мной случаях проверялось несоответствие WindowsXP вызовом not CheckWin32Version(5, 1) — некоторых API (например, Flat ScrollBars устарели и не рекомендуются к использованию в Windows XP и выше). Поскольку функция небольшая, то для понимания ошибки лучше привести ее целиком (модуль Sysutils.pas из Delphi6 SP2):


 function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean;
 begin
   Result := (AMajor > Win32MajorVersion) or
     ((AMajor = Win32MajorVersion) and
     (AMinor >= Win32MinorVersion));
 end;
 

Несложно понять, что функция будет возвращать True с параметрами 5, 1 как на Windows 2000 (версия 5.0), так и на Windows NT (версия 4.0) и других версиях Windows, предшествующих Windows XP.

В Delphi7 эта функция была исправлена:


 function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean;
 begin
   Result := (Win32MajorVersion > AMajor) or
     ((Win32MajorVersion = AMajor) and
     (Win32MinorVersion >= AMinor));
 end;
 

Проблемы, связанные с этой функцией, двояки — во первых, в Delphi6 все функции, опирающиеся на проверку версии Windows через вызов CheckWin32Version, не будут работать — в Windows XP они могут не поддерживаться, а в более младших версиях они так и не будут использованы. Приложения, созданные в Delphi6, использующие эту функцию (при условии, что програмист "адаптировался" к реализации от Borland), могут неожиданно перестать работать правильно после перекомпиляции в Delphi7.

ТИПОВЫЕ РЕШЕНИЯ

Учитывая, что ServicePack2 для Delphi6 на данный момент последнее, а скорее всего — совсем последнее обновление для Delphi6, можно рекомендовать (варианты):

Обновить Delphi6 до Delphi7 Studio.

Заменить функцию CheckWin32Version в модуле SysUtils на версию из Delphi7 (выше). Перекомпилировать VCL.




Как проверять корректность доступа к базе данных

Билл Гейтс женился. Лег спать с молодой женой, а на следующее утро она говорит ему:
- Билли, теперь я знаю, почему твоя фирма называется Microsoft ...

Следующая функция проверяет доступ к базе данных и выдает возможные причины, если доступ не удается осуществить. Функция возвращает значение True в случае успешной операции и False в противном случае.


 function TBDEDirect.CheckDatabase: Boolean;
 var
   DS: TDataSource;
 begin
   Result := False;
   DS := GetDataSource;
   if DS = nil then
   begin
     MessageDlg('Не установлена связь с элементом-источником данных.'+
     'Проверьте установку свойства DataSource.',
     mtError, [mbOK], 0);
     Exit;
   end;
   if DS.DataSet = nil then
   begin
     MessageDlg('Доступ к базе данных невозможен.', mtError,
     [mbOK], 0);
     Exit;
   end;
   if TDBDataSet(DS.DataSet).Database = nil then
   begin
     MessageDlg('Доступ к базе данных невозможен.', mtError,
     [mbOK], 0);
     Exit;
   end;
   if TDBDataSet(DS.DataSet).Database.Handle = nil then
   begin
     MessageDlg('Дескриптор (Handle) БД недоступен.', mtError,
     [mbOK], 0);
     Exit;
   end;
   if DS.DataSet.Handle = nil then
   begin
     MessageDlg('Дескриптор курсора (Cursor-Handle) недоступен.', mtError,
     [mbOK], 0);
     Exit;
   end;
   Result := True;
 end;
 




Проверка кредитной карты

Автор: Shawn Wilson Harvell


 unit Creditc;
 
 {*****************************************************************************
 
 Модуль Delphi для проверки номера кредитной карты
 
 Версия: 1.1
 Дата: Декабрь 20, 1996
 
 Данный модуль создан на основе алгоритма ccard автора Peter Miller.
 Автор не против бесплатного использования, но резервирует все права
 на данный алгоритм.
 
 авторское право 1996 Shawn Wilson Harvell ( shawn@inet.net )
 
 применение:
 
 Внесите данный модуль в список uses любого модуля, которому
 необходим доступ к функции проверки кредитной карты.
 
 IsValidCreditCardNumber( CardNumber, ReturnMessage ) returns Boolean
 
 например, используйте это для уведомления пользователя о недействительности карты.
 
 CardNumber - строка, содержащая номер карты, которую необходимо проверить
 ReturnMessage - строка, с помощью которой функция может возвратить любое сообщение
 ( при этом старое содержимое строки стирается )
 
 возвращает true если номер карточки верен, false - в противном случае.
 
 во входных параметрах функции допускаются тире и пробелы,
 если же возможно присутствие других символов, вы можете их удалить.
 Функция RemoveChar довольно легко позаботится об этом, просто
 передайте ей входную строку и символ, который вы хотите удалить.
 
 Пользователь может свободно изменять код модуля для собственных целей,
 но в случае его распространения он должен сообщить пользователям
 обо всех внесенных изменениях.
 
 Используйте модуль на свой страх и риск, поскольку он свободен от явных
 и неявных гарантий. Ответственность за какой-либо ущерб, причиненный
 данным модулем лежит на его пользователе.
 
 На момент написания модуля он устойчиво работал под Delphi версий 1 и 2,
 для Turbo Pascal необходимо внести некоторые несложные исправления (главным
 образом из-за различия реализации функций в модуле SysUtils).
 
 Если вы нашли этот модуль полезным, имеете какие-то пожелания или предложения,
 отправьте автору письмо по адресу электронной почты shawn@inet.net
 
 История изменений
 
 версия 1.1 -- Декабрь 20, 1996
 исправлена ошибка с Discover card: соответственно увеличина длина маски "database"
 
 версия 1.0 -- Октябрь 26, 1996
 первый выпуск
 
 *****************************************************************************}
 
 interface
 
 uses SysUtils;
 
 function IsValidCreditCardNumber(CardNumber: string; var MessageText: string):
   Boolean;
 
 implementation
 
 const
 
   CardPrefixes: array[1..19] of string =
   ('2014', '2149', '300', '301', '302',
     '303', '304', '305', '34', '36', '37',
     '38', '4', '51', '52', '53', '54', '55', '6011');
 
   CardTypes: array[1..19] of string =
   ('enRoute',
     'enRoute',
     'Diner Club/Carte Blanche',
     'Diner Club/Carte Blanche',
     'Diner Club/Carte Blanche',
     'Diner Club/Carte Blanche',
     'Diner Club/Carte Blanche',
     'Diner Club/Carte Blanche',
     'American Express',
     'Diner Club/Carte Blanche',
     'American Express',
     'Diner Club/Carte Blanche',
     'Visa',
     'MasterCard',
     'MasterCard',
     'MasterCard',
     'MasterCard',
     'MasterCard',
     'Discover');
 
 function RemoveChar(const Input: string; DeletedChar: Char): string;
 var
 
   Index: Word; { переменная счетчика                           }
 begin
 
   { данная функция удаляет все вхождения указанного символа из переданной ей      }
   { строки                                                                        }
   Result := Input;
   for Index := Length(Result) downto 1 do
     if Result[Index] = DeletedChar then
       Delete(Result, Index, 1);
 end;
 
 function ShiftMask(Input: Integer): Integer;
 begin
 
   { простая оболочка для функции сдвига битов числа                              }
   result := (1 shl (Input - 12));
 end;
 
 function ConfirmChecksum(CardNumber: string): Boolean;
 var
 
   CheckSum: Integer; { Содержит значение операции                    }
   Flag: Boolean; { флаг готовности                               }
   Counter: Integer; { индекс счетчика                               }
   PartNumber: string; { используется для извлечения каждой цифры числа}
   Number: Integer; { исп-ся для преобразования каждой цифры в число}
 begin
 
   {**************************************************************************
   Это, вероятно, самая запутанный код, который вы когда-либо видели, я и сам
   запутался, когда работал над ним. Основное, что делает данная функция -
   извлекает каждую цифру из номера карты для использования в формуле проверки
   контрольной суммы, устанавливаемую компаниями. Алгоритм производит выборку,
   начиная от последней цифры и заканчивая первой.
   **************************************************************************}
 
   { получаем стартовое значение счетчика }
   Counter := Length(CardNumber);
   CheckSum := 0;
   PartNumber := '';
   Number := 0;
   Flag := false;
 
   while (Counter >= 1) do
   begin
     { получаем текущую цифру }
     PartNumber := Copy(CardNumber, Counter, 1);
     Number := StrToInt(PartNumber); { преобразуем в число }
     if (Flag) then { только каждую вторую цифру }
     begin
       Number := Number * 2;
       if (Number >= 10) then
         Number := Number - 9;
     end;
     CheckSum := CheckSum + Number;
 
     Flag := not (Flag);
 
     Counter := Counter - 1;
   end;
 
   result := ((CheckSum mod 10) = 0);
 end;
 
 function GetMask(CardName: string): Integer;
 begin
 
   { значение по умолчанию }
   result := 0;
 
   if (CardName = 'MasterCard') then
     result := ShiftMask(16);
   if (CardName = 'Visa') then
     result := (ShiftMask(13) or ShiftMask(16));
   if (CardName = 'American Express') then
     result := ShiftMask(15);
   if (CardName = 'Diner Club/Carte Blanche') then
     result := ShiftMask(14);
   if (CardName = 'Discover') then
     result := ShiftMask(16);
 
 end;
 
 function IsValidCreditCardNumber(CardNumber: string; var MessageText: string):
   Boolean;
 var
 
   StrippedNumber: string;
     { используется для хранения числа без дополнительных символов }
   Index: Integer; { универсальный счетчик для циклов и т.п.                     }
   TheMask: Integer;
     { число, которое мы будем использовать для маски              }
   FoundIt: Boolean;
     { используется для индикации, когда что-либо найдено          }
   CardName: string;
     { хранит имя типа карты                                       }
   PerformChecksum: Boolean;
     { тип enRoute карты если контрольная сумма не сошлась         }
 begin
 
   { сначала избавимся от пробелов и тире }
   StrippedNumber := RemoveChar(CardNumber, ' ');
   StrippedNumber := RemoveChar(StrippedNumber, '-');
 
   { если строка была нулевой длины, то тоже OK }
   if (StrippedNumber = '') then
   begin
     result := true;
     exit;
   end;
 
   { инициализация возвращаемых переменных }
   MessageText := '';
   result := true;
 
   { устанавливаем нашу переменную-флаг }
   FoundIt := false;
 
   { проверка правильности введенных символов в номере карты }
   for Index := 1 to Length(StrippedNumber) do
   begin
     case StrippedNumber[Index] of
       '0'..'9': FoundIt := FoundIt; { другими словами не op }
     else
       MessageText := 'Неверный введенный символ';
       result := false;
       exit;
     end;
   end;
 
   { теперь давайте определим тип используемой карты }
   for Index := 1 to 19 do
   begin
     if (Pos(CardPrefixes[Index], StrippedNumber) = 1) then
     begin
       { мы обнаружили правильный тип }
       FoundIt := true;
       CardName := CardTypes[Index];
       TheMask := GetMask(CardName);
     end;
   end;
 
   { если тип карты не определен, указываем на это }
   if (not FoundIt) then
   begin
     CardName := 'Unknown Card Type';
     TheMask := 0;
     MessageText := 'Неизвестный тип карты ';
     result := false;
     exit;
   end;
 
   { проверка длины }
   if ((Length(StrippedNumber) > 28) and result) then
   begin
     MessageText := 'Номер слишком большой ';
     result := false;
     exit;
   end;
 
   { проверка длины }
   if ((Length(StrippedNumber) < 12) or
     ((shiftmask(length(strippednumber)) and themask) = 0)) then
   begin
     messagetext := 'неверная длина числа';
     result := false;
     exit;
   end;
 
   { проверяем вычисление контрольной суммы }
   if (cardname = 'enroute') then
     performchecksum := false
   else
     performchecksum := true;
 
   if (performchecksum and (not confirmchecksum(strippednumber))) then
   begin
     messagetext := 'неверная контрольная сумма';
     result := false;
     exit;
   end;
 
   { если результат равен true, тогда все ok }
   if (result) then
     messagetext := 'номер верен: тип карты: ' + cardname;
 
   { если строка была нулевой длины, то тоже OK }
   if (strippednumber = '') then
     result := true;
 
 end;
 
 end.
 




Проверка дат в Table


 procedure TMainForm.Table2DATASetText(Sender: TField; const Text: string);
 begin
   try
     Table2.Fields[1].Value := StrToDate(Text);
   except
     MessageDlg('Введите правильную дату!', mtError, [mbOk], 0);
     Abort;
   end;
 end;
 




Проверка на соответствие содержимого TEdit

 // Пример нового языка программирования 
 // разработанного Microsoft для новых русских 
 // "Microsoft Visual Fenya". 
 
 Program Vovan;
   Чиста В_натуре (блин);
   Мотаем_Цикл
   Икс:= Продал (обменял(купил(обналичил(перевел(занял)))));
   Отстегнул_долю (Крыша, 20%);
   Пока (Икс > $1000000)
   Рвем_когти (На_канары);
   Иначе (На_нары);
 Game_over.
 

Как мне проверить на соответствие содержимое компонента TEdit?

Предположим, вы регулярно пользуетесь компонентами TEdit (в отличие от компонентов TDBEdit), и если так, то наилучшим местом для осуществления проверки на соответствие является обработчик события OnExit компонента TEdit. Данное событие наступает при каждом покидании фокуса компонента.

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

Решением в данной ситуации может служить попытка послать сообщение в обработчике события компонента TEdit OnExit вашей форме. Определенное пользователем и посланное сообщение может послужить отправной точкой для начала проверки содержимого поля редактирования. Поскольку посланное сообщение располагается в конце очереди сообщений, то это дает Windows возможность завершить изменение фокуса прежде, чем вы попытаетесь передать фокус другому элементу управления.

Помещенный ниже текст модуля и текстовое представление формы (DFM) призваны продемонстрировать эту технику:


 { *** НАЧАЛО КОДА МОДУЛЯ UNIT1.PAS *** }
 unit Unit1;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms,
     Dialogs, StdCtrls, Mask;
 
 const
   { Определенное пользователем сообщение }
   um_ValidateInput = wm_User + 100;
 
 type
   TForm1 = class(TForm)
     Edit1: TEdit;
     Edit2: TEdit;
     Edit3: TEdit;
     Edit4: TEdit;
     Button1: TButton;
     MaskEdit1: TMaskEdit;
     procedure Edit1Exit(Sender: TObject);
   private
     { обработчик определенного пользователем события }
     procedure ValidateInput(var M: TMessage); message um_ValidateInput;
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.ValidateInput(var M: TMessage);
 begin
   { Следующая строка является строкой проверки. Я хочу убедиться в том, }
   { что первый символ является буквенным символом верхнего регистра. }
   { Помните о преобразовании типа lParam к TEdit. }
   if not (TEdit(M.lParam).Text[1] in ['a'..'z']) then
   begin
     ShowMessage('Содержимое не отвечает требованиям'); { Орем на пользователя }
     TEdit(M.lParam).SetFocus; { Снова устанавливаем фокус }
   end;
 end;
 
 procedure TForm1.Edit1Exit(Sender: TObject);
 begin
   { Посылаем сообщение самому себе, говорящее о необходимости }
   { проверки содержимого. Передаем экземпляр TEdit (Self) как }
   { lParam сообщения. }
   PostMessage(Handle, um_ValidateInput, 0, longint(Sender));
 end;
 
 end.
 { *** КОНЕЦ КОДА МОДУЛЯ UNIT1.PAS *** }
 
 { *** НАЧАЛО КОДА ФАЙЛА UNIT1.DFM *** }
 object Form1: TForm1
   Left = 200
     Top = 99
     Width = 318
     Height = 205
     Caption = 'Form1'
     Font.Color = clWindowText
     Font.Height = -13
     Font.Name = 'System'
     Font.Style = []
     PixelsPerInch = 96
     TextHeight = 16
     object Edit1: TEdit
     Left = 32
       Top = 32
       Width = 121
       Height = 24
       TabOrder = 0
       Text = 'Edit1'
       OnExit = Edit1Exit
   end
   object Edit2: TEdit
     Left = 160
       Top = 32
       Width = 121
       Height = 24
       TabOrder = 1
       Text = 'Edit2'
       OnExit = Edit1Exit
   end
   object Edit3: TEdit
     Left = 32
       Top = 64
       Width = 121
       Height = 24
       TabOrder = 2
       Text = 'Edit3'
       OnExit = Edit1Exit
   end
   object Edit4: TEdit
     Left = 160
       Top = 64
       Width = 121
       Height = 24
       TabOrder = 3
       Text = 'Edit4'
       OnExit = Edit1Exit
   end
   object Button1: TButton
     Left = 112
       Top = 136
       Width = 89
       Height = 33
       Caption = 'Button1'
       TabOrder = 4
   end
 end
 { *** КОНЕЦ КОДА ФАЙЛА UNIT1.DFM *** }
 




Как проверить соединение с Интернетом 2

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


 const INTERNET_CONNECTION_MODEM = 1;
       INTERNET_CONNECTION_LAN   = 2;
       INTERNET_CONNECTdState';
 
 {$R *.DFM}
 
 procedure TForm1.CheckState(Sender: TObject);
 var
   dwConnectionTypes: DWORD;
 begin
   dwConnectionTypes:=IC_MODEM+IC_LAN+IC_PROXY;
   if InternetGetConnectedState(@dwConnectionTypes,0) then
     ShowMessage('Youa connected')
   else
     ShowMessage('No Connection');
 end;
 




Проверить существование определённого URL


Разговор двух заядлых интернетчиков:
- Слышь... это... www.zarplaty.net?
- www.kak.vsegda.net!
- www.kak.zhe.ya.domoy.po.edu?
- www.pesh.com!

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

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

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


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




Как изменить фоновый цвет текста в различных строчках TListBox

После того, как поместите TListBox на форму, необходимо изменить свойство Style в TListBox на lbOwnerDrawFixed. Если не изменить свойство Style, то событие OnDrawItem никогда не вызовется. Теперь поместите следующий код в обработчик события OnDrawItem Вашего TListBox:


 procedure TForm1.ListBox1DrawItem
   (Control: TWinControl; Index: Integer;
   Rect: TRect; State: TOwnerDrawState);
 var
   myColor: TColor;
   myBrush: TBrush;
 begin
   myBrush := TBrush.Create;
   with (Control as TListBox).Canvas do
   begin
     if not Odd(Index) then
       myColor := clSilver
     else
       myColor := clYellow;
 
     myBrush.Style := bsSolid;
     myBrush.Color := myColor;
     Windows.FillRect(handle, Rect, myBrush.Handle);
     Brush.Style := bsClear;
     TextOut(Rect.Left, Rect.Top,
       (Control as TListBox).Items[Index]);
     MyBrush.Free;
   end;
 end;
 




Как изменить заголовок чужого окна



 procedure TForm1.Button1Click(Sender: TObject);
 begin
   SetWindowText(FindWindow(nil, 'Безымянный - Блокнот'),
     'Delphi World FOREVER !!!');
 end;
 




Вывод диалога для выбора каталога


Разговаривают два юзера.
- Я слышал, что если проиграть CD-ROM c Виндоуз 2000 в обратную сторону, то получится послание от сатаны!
- Куда страшней другое: если ты проиграешь его как надо, то инсталлируется Виндоуз 2000...


 uses
   ShellAPI, ShlObj;
 ...
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   TitleName : string;
   lpItemID : PItemIDList;
   BrowseInfo : TBrowseInfo;
   DisplayName : array[0..MAX_PATH] of char;
   TempPath : array[0..MAX_PATH] of char;
 begin
   FillChar(BrowseInfo, sizeof(TBrowseInfo), #0);
   BrowseInfo.hwndOwner := Form1.Handle;
   BrowseInfo.pszDisplayName := @DisplayName;
   TitleName := 'Please specify a directory';
   BrowseInfo.lpszTitle := PChar(TitleName);
   BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;
   lpItemID := SHBrowseForFolder(BrowseInfo);
   if lpItemId <> nil then
   begin
     SHGetPathFromIDList(lpItemID, TempPath);
     ShowMessage(TempPath);
     GlobalFreePtr(lpItemID);
   end;
 end;
 




Вывод диалога для выбора каталога 2


Автор: K.Grudnev@tnet.sochi.ru

функция Shell32.dll SHBrowseForFolder.


 var
   Form1: TForm1;
   Shell: IShellForlder;
   HRES: HResult;
 
 procedure CallBack(Wnd: HWnd; uMsg: Uint; lParam, lpData: LPARAM);
   stdcall;
 var
   S: string;
 begin
   S := 'Выберите папку для установки программы';
   SendMessage(Wnd, BFFM_SetStatusText, 0, LongInt(@S[1]));
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   InfoType: Byte;
   BI: TBrowseInfo;
   S: PChar;
   Image: Integer;
   PIDL: PItemIDList;
   Path: array[0..MAX_PATH - 1] of WideChar;
   ResPIDL: PItemIDList;
 begin
   SHGetSpecialFolderLocation(Handle, CSIDL_PROGRAMS, PIDL);
   S := StrAlloc(128);
   with BI do
   begin
     hWndOwner := Form1.Handle;
     pszDisplayName := S;
     lpszTitle := 'Поиск Папки';
     ulFlags := BIF_StatusText;
     pidlRoot := PIDL;
     lpfn := @CallBack;
     iImage := Image;
   end;
 
   ResPIDL := SHBrowseForFolder(BI);
   SHGetPathFormIDList(ResPIDL, @Path[0]);
   Edit1.Text := StrToPas(@PAth[0]);
   StrDispose(S);
 end;
 




Выбор строки или колонки компонента TStringGrid

Автор: Neil J. Rubenking

Вот функция, выбирающая при нажатии на кнопку первую строку сетки. Это работает независимо от размера сетки и количества фиксированных строк/колонок.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   NewSel: TGridRect;
 begin
   with StringGrid1 do
   begin
     NewSel.Left := FixedCols;
     NewSel.Top := FixedRows;
     NewSel.Right := ColCount - 1;
     NewSel.Bottom := FixedRows;
     Selection := NewSel;
   end;
 end;
 

 StringGrid1.Row := номер строки от нуля;
  StringGrid1.Col := номер столбца от нуля;



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



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



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


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