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

ВИДЕОКУРС ВЗЛОМ
выпущен 2 августа!


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

БОЛЬШОЙ FAQ ПО DELPHI



Пример создания компонента TDBNavigationButton


 unit NavBtn;
 
 { TDBNavigationButton: a data-aware TBitBtn
   Delphi 1 + 2
 
  The Beast
  E-Mail: thebeast_first_666@yahoo.com
  ICQ: 67756646
 }
 
 interface
 
 uses
   WinTypes, WinProcs, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   Messages, StdCtrls, Buttons, dbconsts, DB, DBTables;
 
 type
 
   TNavigationButtonDataLink = class;
 
   TDBNavigationButtonType = (
     nbCustom,
     nbFirst, nbPrior, nbNext, nbLast,
     nbInsert, nbDelete,
     nbEdit,
     nbPost, nbCancel,
     nbRefresh);
 
   TBeforeActionEvent =
     procedure (Sender: TObject; var ActionIsDone: Boolean) of object;
 
   TDbNBDisableReason = (
     drBOF, drEOF, drReadonly,
     drNotEditing, drEditing, drEmpty);
   TDbNBDisableReasons = set of TDbNBDisableReason;
 
 
 { TDBNavigationButton }
 
   TDBNavigationButton = class (TBitBtn)
   private
     FDisableReasons: TDbNBDisableReasons;
     FDataLink: TNavigationButtonDataLink;
     FConfirmDelete: Boolean;
     FButtonEnabled: Boolean;
     FDBNavigationButtonType: TDBNavigationButtonType;
     FOnBeforeAction: TBeforeActionEvent;
     FOldOnGlyphChanged: TNotifyEvent;
     FCustomGlyph: Boolean;
     function GetDataSource: TDataSource;
     procedure SetDataSource(Value: TDataSource);
     procedure SetDBNavigationButtonType(Value: TDBNavigationButtonType);
     procedure ReadButtonEnabled(Reader: TReader);
     procedure WriteButtonEnabled(Writer: TWriter);
     function NumberOfStandardComponentName: Integer;
     function HasStandardComponentName: Boolean;
     procedure LoadGlyph;
     function StoreGlyph: Boolean;
     procedure GlyphChanged(Sender: TObject);
     procedure UpdateEnabled;
     procedure CalcDisableReasons;
   protected
     procedure DataChanged;
     procedure EditingChanged;
     procedure ActiveChanged;
     procedure Loaded; override;
     procedure DefineProperties(Filer: TFiler); override;
     procedure Notification(AComponent: TComponent;
       Operation: TOperation); override;
     procedure CMEnabledChanged(var Message: TMessage);
       message CM_ENABLEDCHANGED;
     procedure Click; override;
     procedure DoAction; virtual;
   public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
   published
     property ConfirmDelete: Boolean
       read FConfirmDelete write FConfirmDelete default True;
     property DataButtonType: TDBNavigationButtonType
       read FDBNavigationButtonType write SetDBNavigationButtonType;
     property DataSource: TDataSource read GetDataSource write SetDataSource;
     property Glyph stored StoreGlyph;
 
 {   Use BeforeAction instead of the Click-event if you want to cancel
     the default-action by setting ActionIsDone to true.
     The Click-event is called before the DoAction-event. }
     property OnBeforeAction: TBeforeActionEvent
       read FOnBeforeAction write FOnBeforeAction;
 
 {   Use DisableReasons to say on what case the button has to be disabled.
     It is set automatic if you set DataButtonType <> nbCustom.
     DisableReason  | Disable if Dataset is...
     ---------------+-------------------------
       drBOF        | EOF
       drEOF        | BOF
       drReadonly   | Readonly
       drNotEditing | Not in insert or edit-mode
       drEditing    | In insert or edit-mode
       drEmpty      | Both BOF and EOF }
     property DisableReasons: TDbNBDisableReasons
       read FDisableReasons write FDisableReasons;
   end;
 
 
 { TNavigationButtonDataLink }
 
   TNavigationButtonDataLink = class(TDataLink)
   private
     FDBNavigationButton: TDBNavigationButton;
   protected
     procedure EditingChanged; override;
     procedure DataSetChanged; override;
     procedure ActiveChanged; override;
   public
     constructor Create(aDBNavigationButton: TDBNavigationButton);
     destructor Destroy; override;
   end;
 
 
 
 procedure Register;
 
 implementation
 
 { $R DBCTRLS} { uses DBCTRLS.RES, but that is already linked by DB.PAS }
 
 
 const
 { RegisterPanel = 'Datensteuerung'; { german }
   RegisterPanel = 'Data Controls';
 
 const
   CtrlNamePrefix = 'dbNavBtn';
   StandardComponentName = 'DBNavigationButton';
 
 const
   BtnTypeName: array[TDBNavigationButtonType] of PChar =
     ('', 'FIRST', 'PRIOR', 'NEXT', 'LAST', 'INSERT', 'DELETE',
      'EDIT', 'POST', 'CANCEL', 'REFRESH');
   BtnName: array[TDBNavigationButtonType] of string =
     ('', 'First', 'Prior', 'Next', 'Last', 'New', 'Delete',
      'Edit', 'Save', 'Cancel', 'Refresh');
 
 
 { TNavigationButtonDataLink }
 
 constructor TNavigationButtonDataLink.Create(aDBNavigationButton: TDBNavigationButton);
 begin
   inherited Create;
   FDBNavigationButton := aDBNavigationButton;
 end;
 
 destructor TNavigationButtonDataLink.Destroy;
 begin
   FDBNavigationButton := nil;
   inherited Destroy;
 end;
 
 procedure TNavigationButtonDataLink.EditingChanged;
 begin
   if FDBNavigationButton <> nil then FDBNavigationButton.EditingChanged;
 end;
 
 procedure TNavigationButtonDataLink.DataSetChanged;
 begin
   if FDBNavigationButton <> nil then FDBNavigationButton.DataChanged;
 end;
 
 procedure TNavigationButtonDataLink.ActiveChanged;
 begin
   if FDBNavigationButton <> nil then FDBNavigationButton.ActiveChanged;
 end;
 
 
 
 { TDBNavigationButton }
 
 constructor TDBNavigationButton.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
   FDataLink := TNavigationButtonDataLink.Create(Self);
   DataButtonType := nbCustom;
   FConfirmDelete := True;
   FButtonEnabled := True;
   FCustomGlyph := false;
   FOldOnGlyphChanged := Glyph.OnChange;
   Glyph.OnChange := GlyphChanged;
   FDisableReasons := [];
 end;
 
 destructor TDBNavigationButton.Destroy;
 begin
   FDataLink.Free;
   FDataLink := nil;
   inherited Destroy;
 end;
 
 procedure TDBNavigationButton.GlyphChanged(Sender: TObject);
 begin
   FCustomGlyph := true;
   if Assigned(FOldOnGlyphChanged) then FOldOnGlyphChanged(Sender);
 end;
 
 function TDBNavigationButton.StoreGlyph: Boolean;
 begin { store only user-defined glyph: }
   result := (FDBNavigationButtonType = nbCustom) or FCustomGlyph;
 end;
 
 procedure TDBNavigationButton.LoadGlyph;
 var
 {$IFNDEF WIN32}
   Buffer: array[0..79] of Char;
 {$ENDIF NDEF WIN32}
   ResName: string;
 begin
   if (FDBNavigationButtonType = nbCustom) then
     exit;
   try
   { Load the Bitmap that DBNavigator would load: }
     FmtStr(ResName, 'dbn_%s', [BtnTypeName[FDBNavigationButtonType]]);
   {$IFDEF WIN32}
     Glyph.Handle := LoadBitmap(HInstance, PChar(ResName));
   {$ELSE DEF WIN32}
   { Glyph.Assign(nil); { clear }
     Glyph.Handle := LoadBitmap(HInstance, StrPCopy(Buffer, ResName));
   {$ENDIF DEF WIN32}
     NumGlyphs := 2;
     FCustomGlyph := false;
   except
   { error: do nothing }
   end;
 end;
 
 procedure TDBNavigationButton.CalcDisableReasons;
 begin
   case FDBNavigationButtonType of
     nbPrior: FDisableReasons := [drBOF, drEditing, drEmpty];
     nbNext: FDisableReasons := [drEOF, drEditing, drEmpty];
     nbFirst: FDisableReasons := [drBOF, drEditing, drEmpty];
     nbLast: FDisableReasons := [drEOF, drEditing, drEmpty];
     nbInsert: FDisableReasons := [drReadonly, drEditing];
     nbEdit: FDisableReasons := [drReadonly, drEditing, drEmpty];
     nbCancel: FDisableReasons := [drNotEditing];
     nbPost: FDisableReasons := [drNotEditing];
     nbRefresh: FDisableReasons := [drEditing];
     nbDelete: FDisableReasons := [drReadonly, drEditing, drEmpty];
   end;
 end;
 
 function TDBNavigationButton.NumberOfStandardComponentName: Integer;
 function NumberOfName(const TestName: String): Integer;
 begin
   if (Length(Name) > Length(TestName)) and
      (Copy(Name, 1, Length(TestName)) = TestName) then
   begin
     try
       result := StrToInt(Copy(Name, Length(TestName) + 1, 255));
     except
       result := 0;
     end;
   end
   else
     result := 0;
 end; { function NumberOfName }
 begin { TDBNavigationButton.NumberOfStandardComponentName }
   result := NumberOfName(StandardComponentName);
   if (result = 0) then
     result := NumberOfName(CtrlNamePrefix + BtnName[FDBNavigationButtonType]);
 end;
 
 function TDBNavigationButton.HasStandardComponentName: Boolean;
 function HasName(const TestName: String): Boolean;
 begin
   if (Length(Name) > Length(TestName)) and
      (Copy(Name, 1, Length(TestName)) = TestName) then
   begin
     try
       result := (StrToInt(Copy(Name, Length(TestName) + 1, 255)) > 0);
     except
       result := false;
     end;
   end
   else
     result := (Name = TestName);
 end; { function HasName }
 begin
   result :=
     HasName(StandardComponentName) or
     HasName(CtrlNamePrefix + BtnName[FDBNavigationButtonType]);
 end;
 
 procedure TDBNavigationButton.SetDBNavigationButtonType(
   Value: TDBNavigationButtonType);
 const
   TooMuch_SomethingIsWrong = 33;
 var
   NewName: string;
   Number: Integer;
 begin
   if (Value = FDBNavigationButtonType) then
     exit;
   if (csLoading in ComponentState) then
   begin
     FDBNavigationButtonType := Value;
     CalcDisableReasons;
     exit;
   end;
   Enabled := True;
   Spacing := -1;
   if (Value = nbCustom) then
     FCustomGlyph := true
   else
     if (FDBNavigationButtonType = nbCustom) or
        (Caption = BtnName[FDBNavigationButtonType]) then
     { Change caption if it was created automatically: }
       Caption := BtnName[Value];
   try { ... to change the name of the component: }
     if (csDesigning in ComponentState) and
        HasStandardComponentName then
     begin
       if (Value = nbCustom) then
         NewName := StandardComponentName
       else
         NewName := CtrlNamePrefix + BtnName[Value];
       if (Owner <> nil) and (Owner.FindComponent(NewName) <> nil) then
       begin
         Number := NumberOfStandardComponentName;
         if (Number = 0) then
           Number := 1;
         repeat
           if (Value = nbCustom) then
             NewName := StandardComponentName + IntToStr(Number)
           else
             NewName := CtrlNamePrefix + BtnName[Value] + IntToStr(Number);
           Inc(Number);
         until (Owner.FindComponent(NewName) = nil) or
               (Number = TooMuch_SomethingIsWrong);
       end;
       Name := NewName;
     end;
   except
   { don't change name if error occured }
   end;
   Enabled := False;
   Enabled := True;
   FDBNavigationButtonType := Value;
   LoadGlyph;
   CalcDisableReasons;
 end;
 
 procedure TDBNavigationButton.Notification(AComponent: TComponent;
   Operation: TOperation);
 begin
   inherited Notification(AComponent, Operation);
   if (Operation = opRemove) and (FDataLink <> nil) and
      (AComponent = DataSource) then DataSource := nil;
 end;
 
 procedure TDBNavigationButton.DoAction;
 var
   Cancel: Boolean;
 begin
   if (not (csDesigning in ComponentState)) and
      Assigned(FOnBeforeAction) then
   begin
     Cancel := (FDBNavigationButtonType = nbCustom);
     FOnBeforeAction(self, Cancel);
     if Cancel then
       exit;
   end;
   if (DataSource <> nil) and (DataSource.State <> dsInactive) then
   begin
     with DataSource.DataSet do
     begin
       case FDBNavigationButtonType of
         nbPrior: Prior;
         nbNext: Next;
         nbFirst: First;
         nbLast: Last;
         nbInsert: Insert;
         nbEdit: Edit;
         nbCancel: Cancel;
         nbPost: Post;
         nbRefresh: Refresh;
         nbDelete:
           {if not FConfirmDelete or
             (MessageDlg(LoadStr(SDeleteRecordQuestion), mtConfirmation,
             mbOKCancel, 0) <> idCancel) then Delete;}
       end;
     end;
   end;
 end;
 
 procedure TDBNavigationButton.Click;
 begin
   inherited Click;
   DoAction;
 end;
 
 procedure TDBNavigationButton.UpdateEnabled;
 var
   PossibleDisableReasons: TDbNBDisableReasons;
 begin
   if (csDesigning in ComponentState) then
     exit;
   if (csDestroying in ComponentState) then
     exit;
   if not FButtonEnabled then
     exit;
   if FDataLink.Active then
   begin
     PossibleDisableReasons := [];
     if FDataLink.DataSet.BOF then
       Include(PossibleDisableReasons, drBOF);
     if FDataLink.DataSet.EOF then
       Include(PossibleDisableReasons, drEOF);
     if not FDataLink.DataSet.CanModify then
       Include(PossibleDisableReasons, drReadonly);
     if FDataLink.DataSet.BOF and FDataLink.DataSet.EOF then
       Include(PossibleDisableReasons, drEmpty);
     if FDataLink.Editing then
       Include(PossibleDisableReasons, drEditing)
     else
       Include(PossibleDisableReasons, drNotEditing);
   end
   else
     PossibleDisableReasons := [drBOF, drEOF, drReadonly, drNotEditing, drEmpty];
   Enabled := (FDisableReasons * PossibleDisableReasons = []);
   FButtonEnabled := true;
 end;
 
 procedure TDBNavigationButton.DataChanged;
 begin
   UpdateEnabled;
 end;
 
 procedure TDBNavigationButton.EditingChanged;
 begin
   UpdateEnabled;
 end;
 
 procedure TDBNavigationButton.ActiveChanged;
 begin
   if not (csDesigning in ComponentState) then
   begin
     UpdateEnabled; { DataChanged; EditingChanged; }
   end;
 end;
 
 procedure TDBNavigationButton.CMEnabledChanged(var Message: TMessage);
 begin
   inherited;
   if (not (csLoading in ComponentState)) and
      (not (csDestroying in ComponentState)) then
   begin
     FButtonEnabled := Enabled;
     ActiveChanged;
   end;
 end;
 
 procedure TDBNavigationButton.SetDataSource(Value: TDataSource);
 begin
   FDataLink.DataSource := Value;
   if not (csLoading in ComponentState) then
     ActiveChanged;
 {$IFDEF WIN32}
   if Value <> nil then Value.FreeNotification(Self);
 {$ENDIF DEF WIN32}
 end;
 
 function TDBNavigationButton.GetDataSource: TDataSource;
 begin
   Result := FDataLink.DataSource;
 end;
 
 procedure TDBNavigationButton.ReadButtonEnabled(Reader: TReader);
 begin
   FButtonEnabled := Reader.ReadBoolean;
 end;
 
 procedure TDBNavigationButton.WriteButtonEnabled(Writer: TWriter);
 begin
   Writer.WriteBoolean(FButtonEnabled);
 end;
 
 procedure TDBNavigationButton.DefineProperties(Filer: TFiler);
 begin
   inherited DefineProperties(Filer);
   Filer.DefineProperty('RuntimeEnabled', ReadButtonEnabled, WriteButtonEnabled, true);
 end;
 
 
 procedure TDBNavigationButton.Loaded;
 begin
   inherited Loaded;
   if Glyph.Empty then { no user-defined glyph: }
     LoadGlyph; { load standard glyph }
   Enabled := FButtonEnabled; {}
   ActiveChanged;
 end;
 
 
 
 procedure Register;
 begin
   RegisterComponents(RegisterPanel, [TDBNavigationButton]);
 end;
 
 end.
 




TDirectoryOutline. Ошибка в свойстве Directory

Автор: Коробенков Владимир

При присвоении свойству TDirectoryOutline.Directory строки, являющейся действительным файловым путем, компонент должен отобразить этот путь раскрытием соответствующей ветви дерева директорий (вызывая защищенный метод WalkTree(). Из-за ошибки в методе SetDirectory WalkTree не вызывается. Ошибка выявлена в Delphi 5, не исправлена и в Delphi 6.

ТИПОВЫЕ РЕШЕНИЯ.
  1. В методе SetDirectory модуля DirOutln.pas строку
    if Copy(FDirectory, Length(FDirectory) - 1, 2) = ':\' then WalkTree(TempPath);
     
    заменить на
    if Copy(FDirectory, Length(FDirectory) - 1, 2) <> ':\' then WalkTree(TempPath);
     
    и перекомпилировать модуль.

  2. Просто не использовать этот компонент.

КОММЕНТАРИЙ:

Проверено (Delphi 5). Ошибка реально существует. По-видимому, этот код не изменялся от самых ранних версий.

Малоизвестный компонент TDirectoryOutline находится на странице Samples палитры компонентов. Это простой и вполне приличный способ получить визуальное дерево директорий. Он построен на основе TCustomGrid->TCustomOutline, а не на базе стандартного Win32-контрола TreeView, и потому лишен присущих ему ограничений и недостатков.

Модификация исходников, не входящих, строго говоря, в VCL, - не есть большая беда. Как вариант, можно предложить в подобных случаях держать модифицированную копию модуля у себя в проекте.




Пример TDrawGrid Drawcell

Автор: Neil


 procedure TForm1.DrawGrid1DrawCell(Sender: TObject; Col, Row: Longint;
   Rect: TRect; State: TGridDrawState);
 var
   vRow, vCol: LongInt;
 begin
   vRow := Row;
   vCol := Col;
   with Sender as TDrawGrid, Canvas do
   begin
     if (vRow = 0) or (vCol = 0) then
       Font.Color := clBlack
     else
       Font.Color := clRed;
     TextRect(Rect, Rect.Left, Rect.Top, Format('(%d,%d)', [vRow, vCol]));
   end;
 end;
 




TEdit с выравниваением текста по центру

Президент Клинтон с целью увеличить общий интерес к наукам и техническим новшествам, пригласил несколько крупных компьютерных компаний участвовать в крупном издательском Мультимедиа-проекте с общей темой "Слоны". Названия частей проекта, сделанных соответственно компаниями:
Аррlе: "Дружественные к пользователям Слоны и их подруга Мышь".
IВМ: "Как продать Слона тому, кто хочет купить Беговую Лошадь".
Nоvеll: "Соединяя Слонов".
Воrlаnd: "Все Слоны должны стоить $99".
NеХТ: "Красим Слона в черный цвет".
Мiсrоsоft: "Почему Вы должны купить Мiсrоsоft Windоws".

TEdit не поддерживает выравниваение текста по центру и по правой стороне - лучше использовать компонент TMemo. Вам понадобится запретить пользователю нажимать Enter, Ctrl-Enter и всевозможные комбинации клавиш со стрелками, чтобы избежать появления нескольких сторк в Memo. Этого можно добиться и просматривая содержимое текста в TMemo в поисках кода возврата каретки (13) и перевода строки(10) на событиях TMemo Change и KeyPress. Можно также заменять код возврата каретки на пробел - для того чтобы позволять вставку из буфера обмена многострочного текста в виде одной строки.

Пример:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Memo1.Alignment := taCenter;
   Memo1.MaxLength := 24;
   Memo1.WantReturns := false;
   Memo1.WordWrap := false;
 end;
 
 procedure MultiLineMemoToSingleLine(Memo: TMemo);
 var
   t: string;
 begin
   t := Memo.Text;
   if Pos(#13, t) > 0 then
   begin
     while Pos(#13, t) > 0 do
       delete(t, Pos(#13, t), 1);
     while Pos(#10, t) > 0 do
       delete(t, Pos(#10, t), 1);
     Memo.Text := t;
   end;
 end;
 
 procedure TForm1.Memo1Change(Sender: TObject);
 begin
   MultiLineMemoToSingleLine(Memo1);
 end;
 
 procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
 begin
   MultiLineMemoToSingleLine(Memo1);
 end;
 




Поиск и управление TEdit и TField

Автор: Robert Wittig

Компания Microsoft благодарит Вас за покупку операционнй системы Microsoft ScanDisk.

Я хотел бы менять цвет компонентов TDBEdit и TEdit, расположенных на форме, на другой, "отчетливый" цвет, в том случае, если с помощью них требуется ввести какие-либо данные.

Как насчет этого? Представляю вашему вниманию два метода. Первый метод задает цвет каждому DBEdit, имеющему требуемое поле. Второй метод (более сложный) задает цвет каждому БД-компоненту, имеющему необходимое поле.


 procedure TForm3.Button3Click(Sender: TObject);
 var
   Control: Integer;
 begin
   for Control := 0 to ControlCount - 1 do
     if Controls[Control] is TDBEdit then
       with TDBEdit(Controls[Control]) do
         if DataSource.DataSet.FieldByName(DataField).Required then
           Color := clRed;
 end;
 
 { Данный метод будет работать только в случае, если
 БД-компонент обладает тремя полями: DataSource, типа
 TDataSource, DataField, типа String, и Color, типа
 TColor (это не должно быть проблемой). Также вам
 необходимо включить TypInfo в список используемых
 модулей }
 
 procedure TForm3.Button4Click(Sender: TObject);
 var
   Control: Integer;
 
   DataSource: TDataSource;
   DataField: string;
 
   function GetDataSource(Instance: TComponent): Boolean;
   var
     PropInfo: PPropInfo;
   begin
     Result := False;
     PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, 'DataSource');
     if (PropInfo <> nil) and
       (PropInfo^.PropType^.Kind = tkClass) then
     begin
       DataSource := TDataSource(TypInfo.GetOrdProp(Instance, PropInfo));
       Result := DataSource <> nil;
     end;
   end;
 
   function GetDataField(Instance: TComponent): Boolean;
   var
     PropInfo: PPropInfo;
   begin
     Result := False;
     PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, 'DataField');
     if (PropInfo <> nil) and
       (PropInfo^.PropType^.Kind = tkString) then
     begin
       DataField := TypInfo.GetStrProp(Instance, PropInfo);
       Result := True;
     end;
   end;
 
   procedure SetColor(Instance: TComponent; Color: TColor);
   var
     PropInfo: PPropInfo;
   begin
     PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, 'Color');
     if (PropInfo <> nil) and
       (PropInfo^.PropType^.Kind = tkInteger) then
       TypInfo.SetOrdProp(Instance, PropInfo, Ord(Color));
   end;
 
 begin
   for Control := 0 to ControlCount - 1 do
     if GetDataSource(Controls[Control]) and
       GetDataField(Controls[Control]) and
       (DataSource.DataSet <> nil) and
       DataSource.DataSet.FieldByName(DataField).Required then
       SetColor(Controls[Control], clRed);
 end;
 




Как создать нестандартную процедуру переноса слов для TEdit, TMemo

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

В следующем примере создается процедура разбиения слов при переносах для TMemo. Заметьте, что реализованная процедура просто всегда разрешает перенос. Для дополнительной информации см.таже документацию к сообщению EM_SETWORDBREAKPROC.


 var
   OriginalWordBreakProc: pointer;
   NewWordBreakProc: pointer;
 
 function MyWordBreakProc(LPTSTR: pchar;
   ichCurrent: integer;
   cch: integer;
   code: integer): integer
 {$IFDEF WIN32} stdcall;
 {$ELSE}; export;
 {$ENDIF}
 begin
   result := 0;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   OriginalWordBreakProc := Pointer(
     SendMessage(Memo1.Handle,
     EM_GETWORDBREAKPROC,
     0,
     0));
 {$IFDEF WIN32}
   NewWordBreakProc := @MyWordBreakProc;
 {$ELSE}
   NewWordBreakProc := MakeProcInstance(@MyWordBreakProc,
     hInstance);
 {$ENDIF}
   SendMessage(Memo1.Handle,
     EM_SETWORDBREAKPROC,
     0,
     longint(NewWordBreakProc));
 
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   SendMessage(Memo1.Handle,
     EM_SETWORDBREAKPROC,
     0,
     longint(@OriginalWordBreakProc));
 {$IFNDEF WIN32}
   FreeProcInstance(NewWordBreakProc);
 {$ENDIF}
 end;
 




Шаблон массива переменной длины

Автор: Ed Jordan

Может ли кто мне подсказать как динамически создать массив записей и получить доступ к отдельным элементам?

Определите тип массива, которым может содержать максимальное количество записей, затем определите тип, являющийся указателем на массив. Идея заключается в том, чтобы не создавать экземпляр самого большого массива; а вместо этого использовать указательный тип и GetMem для распределения памяти для необходимого вам количества записей.

Я разработал то, что я называю шаблоном массива переменной длины "для бедных людей"...


 unit %s;
 
 { -----------------------------------------------------------
 
 ШАБЛОН МАССИВА ПЕРЕМЕННОЙ ДЛИНЫ
 
 Вы можете использовать этот шаблон для создания массива
 переменной длины любого типа данных.
 
 Для того, чтобы превратить шаблон с модуль, прогоните его
 через текстовый процессор, выполните во всем файле операцию
 поиска/замены для замены знака процента на ваш тип данных.
 ----------------------------------------------------------- }
 
 interface
 
 const
 
   %MaxCapacity = High(Cardinal) div SizeOf(%);
 
 type
 
   T%Index = 0..%MaxCapacity - 1;
 
   T%s = array[T%Index] of %;
   P%s = ^T%s;
 
 function %sSize(Capacity: T%Index): Cardinal;
 function Get%s(Capacity: T%Index): P%s;
 function Resize%s(var P: P%s;
 
   OldCapacity, NewCapacity: T%Index): P%s;
 procedure Free%s(var P: P%s; Capacity: T%Index);
 
 implementation
 uses SysUtils;
 
 function %sSize(Capacity: T%Index): Cardinal;
 begin
 
   Result := Capacity * SizeOf(%);
 end;
 
 function Get%s(Capacity: T%Index): P%s;
 begin
 
   GetMem(Result, %sSize(Capacity));
 end;
 
 function Resize%s(var P: P%s;
 
   OldCapacity, NewCapacity: T%Index): P%s;
 begin
 
   ReAllocMem(P, %sSize(OldCapacity), %sSize(NewCapacity));
 end;
 
 procedure Free%s(var P: P%s; Capacity: T%Index);
 begin
 
   FreeMem(P, %sSize(Capacity));
   P := nil;
 end;
 
 end.
 

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

Вот модуль, использующий после операции поиска и замены (см. выше) тип записи 'MyRecord', содержащий также определение этой записи. Поскольку "MyRecords" было очень длинным для имени модуля, я укоротил его. Имейте в виду, что PMyRecords - тип вашего переменного массива, если вы используете этот модуль.


 unit MyRecs;
 interface
 
 type
 
   MyRecord = record
     AnInt: Integer;
     AString: string[10];
   end;
 
 const
 
   MyRecordMaxCapacity = High(Cardinal) div SizeOf(MyRecord);
 
 type
 
   TMyRecordIndex = 0..MyRecordMaxCapacity - 1;
 
   TMyRecords = array[TMyRecordIndex] of MyRecord;
   PMyRecords = ^TMyRecords;
 
 function MyRecordsSize(Capacity: TMyRecordIndex): Cardinal;
 function GetMyRecords(Capacity: TMyRecordIndex): PMyRecords;
 function ResizeMyRecords(var P: PMyRecords;
 
   OldCapacity, NewCapacity: TMyRecordIndex): PMyRecords;
 procedure FreeMyRecords(var P: PMyRecords; Capacity: TMyRecordIndex);
 
 implementation
 uses SysUtils;
 
 function MyRecordsSize(Capacity: TMyRecordIndex): Cardinal;
 begin
 
   Result := Capacity * SizeOf(MyRecord);
 end;
 
 function GetMyRecords(Capacity: TMyRecordIndex): PMyRecords;
 begin
 
   GetMem(Result, MyRecordsSize(Capacity));
 end;
 
 function ResizeMyRecords(var P: PMyRecords;
 
   OldCapacity, NewCapacity: TMyRecordIndex): PMyRecords;
 begin
 
   ReAllocMem(P, MyRecordsSize(OldCapacity),
     MyRecordsSize(NewCapacity));
 end;
 
 procedure FreeMyRecords(var P: PMyRecords; Capacity: TMyRecordIndex);
 begin
 
   FreeMem(P, MyRecordsSize(Capacity));
   P := nil;
 end;
 
 end.
 

Наконец, вот пример использования массива переменной длины. Помните, что указатель должен использоваться с символом "^"...


 procedure TForm1.Button1Click( Sender: TObject );
 var
   P: PMyRecords;
 begin
   P := GetMyRecords( 10 );
   try
     P^[ 0 ].AnInt := 2001;
     P^[ 0 ].AString := 'Космическая одиссея';
   finally
     FreeMyRecords( P, 10 );
   end;
 end;
 




Завершение всех работающих приложений

Как мне завершить все работающие задачи?

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

Поэтому, прежде чем запустить этот код, убедитесь в наличии сохраненных данных и в том, что пользователь осведомлен об этой операции.


 procedure TForm1.ButtonKillAllClick(Sender: TObject);
 var
   pTask: PTaskEntry;
   Task: Bool;
   ThisTask: THANDLE;
 begin
   GetMem(pTask, SizeOf(TTaskEntry));
   pTask^.dwSize := SizeOf(TTaskEntry);
 
   Task := TaskFirst(pTask);
   while Task do
   begin
     if pTask^.hInst = hInstance then
       ThisTask := pTask^.hTask
     else
       TerminateApp(pTask^.hTask, NO_UAE_BOX);
     Task := TaskNext(pTask);
   end;
   TerminateApp(ThisTask, NO_UAE_BOX);
 end;
 




Как завершить любой процесс, в том числе и системный

Женщина спрашивает совета у доктора: - Доктор,мой 17-летний сын так увлекся компьютером,что даже спит возле него.Как его отучить? - Очень просто! Вино, водка, сигареты, женщины ...


  // Включение, приминение и отключения привилегии.
  // Для примера возьмем привилегию отладки приложений 'SeDebugPrivilege'
  // необходимую для завершения ЛЮБЫХ процессов в системе (завершение процесов
  // созданных текущим пользователем привилегия не нужна.
 
 function ProcessTerminate(dwPID:Cardinal):Boolean;
 var
  hToken:THandle;
  SeDebugNameValue:Int64;
  tkp:TOKEN_PRIVILEGES;
  ReturnLength:Cardinal;
  hProcess:THandle;
 begin
  Result:=false;
  // Добавляем привилегию SeDebugPrivilege 
  // Для начала получаем токен нашего процесса
  if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES
   or TOKEN_QUERY, hToken ) then
     exit;
 
  // Получаем LUID привилегии
  if not LookupPrivilegeValue( nil, 'SeDebugPrivilege', SeDebugNameValue )
   then begin
    CloseHandle(hToken);
    exit;
   end;
 
  tkp.PrivilegeCount:= 1;
  tkp.Privileges[0].Luid := SeDebugNameValue;
  tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
 
  // Добавляем привилегию к нашему процессу
  AdjustTokenPrivileges(hToken,false,tkp,SizeOf(tkp),tkp,ReturnLength);
  if GetLastError()< > ERROR_SUCCESS  then exit;
 
  // Завершаем процесс. Если у нас есть SeDebugPrivilege, то мы можем
  // завершить и системный процесс
  // Получаем дескриптор процесса для его завершения
  hProcess := OpenProcess(PROCESS_TERMINATE, FALSE, dwPID);
  if hProcess =0  then exit;
   // Завершаем процесс
    if not TerminateProcess(hProcess, DWORD(-1))
     then exit;
  CloseHandle( hProcess );
 
  // Удаляем привилегию 
  tkp.Privileges[0].Attributes := 0;
  AdjustTokenPrivileges(hToken, FALSE, tkp, SizeOf(tkp), tkp, ReturnLength);
  if GetLastError() < >  ERROR_SUCCESS
   then exit;
 
  Result:=true;
 end;
 
  // Название добавление/удаление привилгии немного неправильные.  Привилегия или 
  // есть в токене процесса или ее нет. Если привилегия есть, то она может быть в 
  // двух состояниях - или включеная или отключеная. И в этом примере мы только 
  // включаем или выключаем необходимую привилегию, а не добавляем ее.
 




Завершить чужое приложение

Приложение запущено. Сильно запущено...


 PostMessage(FindWindow(nil, 'Заголовок окна'), WM_QUIT, 0, 0);
 




Тест на корректность идентификатора GUID и интерфейсов IDispatch

Автор: Nomadic

Как осуществить минимальный тест на корректность глобального идентификатора (GUID), и интерфейсов, унаследованных от IDispatch (и, следовательно, поддерживающих методы автоматизации)?

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


 const
   MyGUID = '{444...111}'; //Whatever the guid is...
 
 var
   Unk: IUnknown;
   Disp: IDispatch;
 
 begin
   { Make sure this line works correctly }
   Unk := CreateRemoteComObject('server1',
     StringToGUID(MyGUID));
 
   { If it does, then cast it to a IDispatch }
   Disp := Unk as IDispatch;
 end;
 

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




Функция, возвращающая текст между двумя определёнными строками


 Procedure IsolateText( Const S: String; Tag1, Tag2: String; list:TStrings );
   Var
     pScan, pEnd, pTag1, pTag2: PChar;
     foundText: String;
     searchtext: String;
   Begin
     { Set up pointers we need for the search. HTML is not case sensitive, so
       we need to perform the search on a uppercased copy of S.}
     searchtext := Uppercase(S);
     Tag1:= Uppercase( Tag1 );
     Tag2:= Uppercase( Tag2 );
     pTag1:= PChar(Tag1);
     pTag2:= PChar(Tag2);
     pScan:= PChar(searchtext);
     Repeat
       { Search for next occurence of Tag1. }
       pScan:= StrPos( pScan, pTag1 );
       If pScan <> Nil Then Begin
         { Found one, hop over it, then search from that position
           forward for the next occurence of Tag2. }
         Inc(pScan, Length( Tag1 ));
         pEnd := StrPos( pScan, pTag2 );
         If pEnd <> Nil Then Begin
           { Found start and end tag, isolate text between,
             add it to the list. We need to get the text from
             the original S, however, since we want the un-uppercased
             version! So we calculate the address pScan would hold if
             the search had been performed on S instead of searchtext. }
           SetString( foundText,
                      Pchar(S) + (pScan- PChar(searchtext) ),
                      pEnd - pScan );
           list.Add( foundText );
 
           { Continue next search after the found end tag. }
           pScan := pEnd + Length(tag2);
         End { If }
         Else { Error, no end tag found for start tag, abort. }
           pScan := Nil;
       End; { If }
     Until pScan = Nil;
   End;
 




Как текст на кнопке расположить под заданным углом

Как выдать текст под наклоном? Чтобы вывести под любым углом текст необходимо использовать TrueType Fonts (например «Arial»). Например:


 var
   LogFont: TLogFont;
 begin
   GetObject(Canvas.Font.Handle, SizeOf(TLogFont), @LogFont);
   {Вывести текст 1/10 градуса против часовой стрелки}
   LogFont.lfEscapement := Angle * 10;
   Canvas.Font.Handle := CreateFontIndirect(LogFont);
 end;
 




Пример шифрования текста


 const
   csCryptFirst = 20;
   csCryptSecond = 230;
   csCryptHeader = 'Crypted';
 
 type
   ECryptError = class(Exception);
 
 function CryptString(Str:String):String;
 var i,clen : Integer;
 begin
   clen := Length(csCryptHeader);
   SetLength(Result, Length(Str)+clen);
   Move(csCryptHeader[1], Result[1], clen);
   For i := 1 to Length(Str) do
    begin
     if i mod 2 = 0 then
      Result[i+clen] := Chr(Ord(Str[i]) xor csCryptFirst)
     else
      Result[i+clen] := Chr(Ord(Str[i]) xor csCryptSecond);
    end;
 end;
 
 function UnCryptString(Str:String):String;
 var i, clen : Integer;
 begin
   clen := Length(csCryptHeader);
   SetLength(Result, Length(Str)-clen);
   if Copy(Str, 1, clen) < > csCryptHeader then
    raise ECryptError.Create('UnCryptString failed');
 
   For i := 1 to Length(Str)-clen do
    begin
     if (i) mod 2 = 0 then
      Result[i] := Chr(Ord(Str[i+clen]) xor csCryptFirst)
     else
      Result[i] := Chr(Ord(Str[i+clen]) xor csCryptSecond);
    end;
 end;
 




Как реализовать поиск по тексту



 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if OpenDialog1.Execute then
     Memo1.Lines.LoadFromFile(OpenDialog1.FileName);
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 var
   find: string;
   text: string;
   st, len: integer;
   res: integer;
 begin
   if Memo1.SelStart >= Length(Memo1.Text) then
     Memo1.SelStart := 0;
   st := Memo1.SelStart + 1;
   if (Memo1.SelLength <= 0) or (not CheckBox1.Checked) then
   begin
     inc(st, Memo1.SelLength);
     len := Length(Memo1.Text) - st;
   end
   else
     len := Memo1.SelLength;
   text := copy(Memo1.Text, st, len);
   find := Edit1.Text;
   res := pos(find, text);
   if res = 0 then
   begin
     ShowMessage('Search string "' + find + '" not found');
     Exit;
   end;
   Memo1.SelStart := res + st - 2;
   Memo1.SelLength := length(find);
 end;
 




Отображаем текст в System Tray

Данный код сперва конвертирует Ваш текст в DIB, а затем DIB в иконку и далее в ресурс. После этого изображение иконки отображается в System Tray.

Вызов просходит следующим образом:


 StringToIcon('Delphi World Is Cool !!!');
 // Не забудьте удалить объект HIcon, после вызова функции... 
 


 unit MainForm;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls, ExtCtrls;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     Image1: TImage;
     Timer1: TTimer;
     procedure Button1Click(Sender: TObject);
     procedure Timer1Timer(Sender: TObject);
   private
     function StringToIcon (const st : string) : HIcon;
   public
     { Public declarations }
 end;
 
 var
   Form1: TForm1;
 
 implementation
 {$R *.DFM}
 
 type
   ICONIMAGE = record
     Width, Height, Colors : DWORD; // Ширина, Высота и кол-во цветов 
     lpBits : PChar; // указатель на DIB биты 
     dwNumBytes : DWORD; // Сколько байт? 
     lpbi : PBitmapInfoHeader; // указатель на заголовок 
     lpXOR : PChar; // указатель на XOR биты изображения 
     lpAND : PChar; // указатель на AND биты изображения 
 end;
 
 function CopyColorTable (var lpTarget: BITMAPINFO;
 const lpSource: BITMAPINFO): boolean;
 var
   dc : HDC;
   hPal : HPALETTE;
   pe : array [0..255] of PALETTEENTRY;
   i : Integer;
 begin
   result := False;
   case (lpTarget.bmiHeader.biBitCount) of
     8 :
       if lpSource.bmiHeader.biBitCount = 8 then
       begin
         Move (lpSource.bmiColors, lpTarget.bmiColors, 256 * sizeof (RGBQUAD));
         result := True
       end
       else
       begin
         dc := GetDC (0);
         if dc <> 0 then
           try
             hPal := CreateHalftonePalette (dc);
             if hPal <> 0 then
               try
                 if GetPaletteEntries (hPal, 0, 256, pe) <> 0 then
                 begin
                   for i := 0 to 255 do
                   begin
                     lpTarget.bmiColors [i].rgbRed := pe [i].peRed;
                     lpTarget.bmiColors [i].rgbGreen := pe [i].peGreen;
                     lpTarget.bmiColors [i].rgbBlue := pe [i].peBlue;
                     lpTarget.bmiColors [i].rgbReserved := pe [i].peFlags;
                   end;
                   result := True
                 end
               finally
                 DeleteObject (hPal)
               end
           finally
             ReleaseDC (0, dc)
           end
       end;
     4 :
       if lpSource.bmiHeader.biBitCount = 4 then
       begin
         Move (lpSource.bmiColors, lpTarget.bmiColors, 16 * sizeof (RGBQUAD));
         result := True
       end
       else
       begin
         hPal := GetStockObject (DEFAULT_PALETTE);
         if (hPal <> 0) and (GetPaletteEntries (hPal, 0, 16, pe) <> 0) then
         begin
           for i := 0 to 15 do
           begin
             lpTarget.bmiColors [i].rgbRed := pe [i].peRed;
             lpTarget.bmiColors [i].rgbGreen := pe [i].peGreen;
             lpTarget.bmiColors [i].rgbBlue := pe [i].peBlue;
             lpTarget.bmiColors [i].rgbReserved := pe [i].peFlags;
           end;
           result := True
         end
       end;
     1:
     begin
       i := 0;
       lpTarget.bmiColors[i].rgbRed := 0;
       lpTarget.bmiColors[i].rgbGreen := 0;
       lpTarget.bmiColors[i].rgbBlue := 0;
       lpTarget.bmiColors[i].rgbReserved := 0;
       i := 1;
       lpTarget.bmiColors[i].rgbRed := 255;
       lpTarget.bmiColors[i].rgbGreen := 255;
       lpTarget.bmiColors[i].rgbBlue := 255;
       lpTarget.bmiColors[i].rgbReserved := 0;
       result := True
     end;
   else
     result := True
   end
 end;
 
 function WidthBytes (bits : DWORD) : DWORD;
 begin
   result := ((bits + 31) shr 5) shl 2;
 end;
 
 function BytesPerLine (const bmih : BITMAPINFOHEADER) : DWORD;
 begin
   result := WidthBytes (bmih.biWidth * bmih.biPlanes * bmih.biBitCount);
 end;
 
 function DIBNumColors (const lpbi : BitmapInfoHeader) : word;
 var
   dwClrUsed : DWORD;
 begin
   dwClrUsed := lpbi.biClrUsed;
   if dwClrUsed <> 0 then
     result := Word (dwClrUsed)
   else
     case lpbi.biBitCount of
       1 : result := 2;
       4 : result := 16;
       8 : result := 256
       else
         result := 0;
     end
 end;
 
 function PaletteSize (const lpbi : BitmapInfoHeader) : word;
 begin
   result := DIBNumColors (lpbi) * sizeof (RGBQUAD);
 end;
 
 function FindDIBBits (const lpbi : BitmapInfo) : PChar;
 begin
   result := @lpbi;
   result := result + lpbi.bmiHeader.biSize + PaletteSize (lpbi.bmiHeader);
 end;
 
 function ConvertDIBFormat (var lpSrcDIB : BITMAPINFO; nWidth, nHeight,
 nbpp : DWORD; bStretch : boolean) : PBitmapInfo;
 var
   lpbmi : PBITMAPINFO;
   lpSourceBits, lpTargetBits : Pointer;
   DC, hSourceDC, hTargetDC : HDC;
   hSourceBitmap, hTargetBitmap, hOldTargetBitmap, hOldSourceBitmap : HBITMAP;
   dwSourceBitsSize, dwTargetBitsSize, dwTargetHeaderSize : DWORD;
 begin
   result := nil;
   // Располагаем и заполняем структуру BITMAPINFO для нового DIB 
   // Обеспечиваем достаточно места для 256-цветной таблицы 
   dwTargetHeaderSize := sizeof ( BITMAPINFO ) + ( 256 * sizeof( RGBQUAD ) );
   GetMem (lpbmi, dwTargetHeaderSize);
   try
     lpbmi^.bmiHeader.biSize := sizeof (BITMAPINFOHEADER);
     lpbmi^.bmiHeader.biWidth := nWidth;
     lpbmi^.bmiHeader.biHeight := nHeight;
     lpbmi^.bmiHeader.biPlanes := 1;
     lpbmi^.bmiHeader.biBitCount := nbpp;
     lpbmi^.bmiHeader.biCompression := BI_RGB;
     lpbmi^.bmiHeader.biSizeImage := 0;
     lpbmi^.bmiHeader.biXPelsPerMeter := 0;
     lpbmi^.bmiHeader.biYPelsPerMeter := 0;
     lpbmi^.bmiHeader.biClrUsed := 0;
     lpbmi^.bmiHeader.biClrImportant := 0;
     // Заполняем в таблице цветов 
     if CopyColorTable (lpbmi^, lpSrcDIB) then
     begin
       DC := GetDC (0);
       hTargetBitmap := CreateDIBSection (DC, lpbmi^, DIB_RGB_COLORS, lpTargetBits, 0, 0 );
       hSourceBitmap := CreateDIBSection (DC, lpSrcDIB, DIB_RGB_COLORS, lpSourceBits, 0, 0 );
       try
         if (dc <> 0) and (hTargetBitmap <> 0) and (hSourceBitmap <> 0) then
         begin
           hSourceDC := CreateCompatibleDC (DC);
           hTargetDC := CreateCompatibleDC (DC);
           try
             if (hSourceDC <> 0) and (hTargetDC <> 0) then
             begin
               // Flip the bits on the source DIBSection to match the source DIB 
               dwSourceBitsSize := DWORD (lpSrcDIB.bmiHeader.biHeight) * BytesPerLine(lpSrcDIB.bmiHeader);
               dwTargetBitsSize := DWORD (lpbmi^.bmiHeader.biHeight) * BytesPerLine(lpbmi^.bmiHeader);
               Move (FindDIBBits (lpSrcDIB)^, lpSourceBits^, dwSourceBitsSize );
               // Select DIBSections into DCs 
               hOldSourceBitmap := SelectObject( hSourceDC, hSourceBitmap );
               hOldTargetBitmap := SelectObject( hTargetDC, hTargetBitmap );
               try
                 if (hOldSourceBitmap <> 0) and (hOldTargetBitmap <> 0) then
                 begin
                   // Устанавливаем таблицу цветов для DIBSections 
                   if lpSrcDIB.bmiHeader.biBitCount <= 8 then
                     SetDIBColorTable (hSourceDC, 0, 1 shl lpSrcDIB.bmiHeader.biBitCount, lpSrcDIB.bmiColors);
                   if lpbmi^.bmiHeader.biBitCount <= 8 then
                     SetDIBColorTable (hTargetDC, 0, 1 shl lpbmi^.bmiHeader.biBitCount, lpbmi^.bmiColors );
                   // If we are asking for a straight copy, do it 
                   if (lpSrcDIB.bmiHeader.biWidth = lpbmi^.bmiHeader.biWidth) and
                   (lpSrcDIB.bmiHeader.biHeight = lpbmi^.bmiHeader.biHeight) then
                     BitBlt (hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth, lpbmi^.bmiHeader.biHeight,
                     hSourceDC, 0, 0, SRCCOPY)
                   else
                   if bStretch then
                   begin
                     SetStretchBltMode (hTargetDC, COLORONCOLOR);
                     StretchBlt (hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth,
                     lpbmi^.bmiHeader.biHeight, hSourceDC, 0, 0, lpSrcDIB.bmiHeader.biWidth,
                     lpSrcDIB.bmiHeader.biHeight, SRCCOPY );
                   end
                   else
                     BitBlt (hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth,
                     lpbmi^.bmiHeader.biHeight, hSourceDC, 0, 0, SRCCOPY );
                   GDIFlush;
                   GetMem (result, Integer (dwTargetHeaderSize + dwTargetBitsSize));
                   Move (lpbmi^, result^, dwTargetHeaderSize);
                   Move (lpTargetBits^, FindDIBBits (result^)^, dwTargetBitsSize);
                 end
               finally
                 if hOldSourceBitmap <> 0 then
                   SelectObject (hSourceDC, hOldSourceBitmap);
                 if hOldTargetBitmap <> 0 then
                   SelectObject (hTargetDC, hOldTargetBitmap);
               end
             end
           finally
             if hSourceDC <> 0 then
               DeleteDC (hSourceDC);
             if hTargetDC <> 0 then
               DeleteDC (hTargetDC);
           end
         end;
       finally
         if hTargetBitmap <> 0 then
           DeleteObject (hTargetBitmap);
         if hSourceBitmap <> 0 then
           DeleteObject (hSourceBitmap);
         if dc <> 0 then
           ReleaseDC (0, dc)
       end
     end
   finally
     FreeMem (lpbmi)
   end
 end;
 
 function DIBToIconImage (var lpii : ICONIMAGE; var lpDIB:
 BitmapInfo; bStretch : boolean) : boolean;
 var
   lpNewDIB : PBitmapInfo;
 begin
   result := False;
   lpNewDIB := ConvertDIBFormat (lpDIB, lpii.Width, lpii.Height, lpii.Colors, bStretch );
   if Assigned (lpNewDIB) then
     try
       lpii.dwNumBytes := sizeof (BITMAPINFOHEADER)// Заголовок 
       + PaletteSize (lpNewDIB^.bmiHeader)// Палитра
       + lpii.Height * BytesPerLine (lpNewDIB^.bmiHeader)// XOR маска 
       + lpii.Height * WIDTHBYTES (lpii.Width);// AND маска 
       // Если здесь уже картинка, то освобождаем её 
     if lpii.lpBits <> nil then
       FreeMem (lpii.lpBits);
     GetMem (lpii.lpBits, lpii.dwNumBytes);
     Move (lpNewDib^, lpii.lpBits^, sizeof (BITMAPINFOHEADER) + PaletteSize (lpNewDIB^.bmiHeader));
     // Выравниваем внутренние указатели/переменные для новой картинки 
     lpii.lpbi := PBITMAPINFOHEADER (lpii.lpBits);
     lpii.lpbi^.biHeight := lpii.lpbi^.biHeight * 2;
     lpii.lpXOR := FindDIBBits (PBitmapInfo (lpii.lpbi)^);
     Move (FindDIBBits (lpNewDIB^)^, lpii.lpXOR^,
     lpii.Height * BytesPerLine (lpNewDIB^.bmiHeader));
     lpii.lpAND := lpii.lpXOR + lpii.Height *
     BytesPerLine (lpNewDIB^.bmiHeader);
     Fillchar (lpii.lpAnd^, lpii.Height * WIDTHBYTES (lpii.Width), $00);
     result := True
   finally
     FreeMem (lpNewDIB)
   end
 end;
 
 function TForm1.StringToIcon (const st : string) : HIcon;
 var
   memDC : HDC;
   bmp : HBITMAP;
   oldObj : HGDIOBJ;
   rect : TRect;
   size : TSize;
   infoHeaderSize : DWORD;
   imageSize : DWORD;
   infoHeader : PBitmapInfo;
   icon : IconImage;
   oldFont : HFONT;
 begin
   result := 0;
   memDC := CreateCompatibleDC (0);
   if memDC <> 0 then
     try
       bmp := CreateCompatibleBitmap (Canvas.Handle, 16, 16);
       if bmp <> 0 then
         try
           oldObj := SelectObject (memDC, bmp);
           if oldObj <> 0 then
             try
               rect.Left := 0;
               rect.top := 0;
               rect.Right := 16;
               rect.Bottom := 16;
               SetTextColor (memDC, RGB (255, 0, 0));
               SetBkColor (memDC, RGB (128, 128, 128));
               oldFont := SelectObject (memDC, font.Handle);
               GetTextExtentPoint32 (memDC, PChar (st), Length (st), size);
               ExtTextOut (memDC, (rect.Right - size.cx) div 2,
               (rect.Bottom - size.cy) div 2, ETO_OPAQUE, @rect,
               PChar (st), Length (st), nil);
               SelectObject (memDC, oldFont);
               GDIFlush;
               GetDibSizes (bmp, infoHeaderSize, imageSize);
               GetMem (infoHeader, infoHeaderSize + ImageSize);
               try
                 GetDib (bmp, SystemPalette16, infoHeader^,
                 PChar (DWORD (infoHeader) + infoHeaderSize)^);
                 icon.Colors := 4;
                 icon.Width := 32;
                 icon.Height := 32;
                 icon.lpBits := nil;
                 if DibToIconImage (icon, infoHeader^, True) then
                   try
                     result := CreateIconFromResource (PByte (icon.lpBits),
                     icon.dwNumBytes, True, $00030000);
                   finally
                     FreeMem (icon.lpBits)
                   end
               finally
                 FreeMem (infoHeader)
               end
             finally
               SelectObject (memDC, oldOBJ)
             end
           finally
             DeleteObject (bmp)
           end
         finally
           DeleteDC (memDC)
         end
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Application.Icon.Handle := StringToIcon ('0');
   Timer1.Enabled := True;
   Button1.Enabled := False;
 end;
 
 procedure TForm1.Timer1Timer(Sender: TObject);
 const
   i : Integer = 0;
 begin
   Inc (i);
   if i = 100 then
     i := 1;
   Application.Icon.Handle := StringToIcon (IntToStr (i));
 end;
 
 end.
 




Использование нумерации в TFields

Автор: Mike Orriss

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

Можете попробовать сделать так:


 type Tcodes = (c1,c2,c3,c4);
 
 var code: Tcodes;
 
 code := Tcodes(Table1Field1.AsInteger);
 if code in [c2,c4] then .....
   Table1Field1.AsInteger := Integer(code);
 




Как задать выражение по умолчанию для объекта TField

Это будет работать, если вы уже установили атрибуты поля и ассоциировали его с полем вашей таблицы. Если вы установили значение в Инспекторе Объектов, т.е. задали строку, не думайте, что это сработает во время выполнения приложения. Если вы попытаетесь во время прогона установить свойство TField.DefaultExpression примерно так:


 MyField.DefaultExpression := 'MyValue';
 

то это скомпилируется, но при создании в таблице новой записи, скажем, при щелчке на кнопке + в DBNavigator, значения по умолчанию вы не получите. Чтобы во время работы приложения все работало, код должен быть таким:


 MyField.DefaultExpression := '''MyValue''';
 

В Инспекторе Объектов вам нужно просто поместить значение 'MyValue' (используя одинарные кавычки).




Сохранить объект TFont в реестре


 uses Registry;
 
 procedure SaveFontToRegistry(Font : TFont; SubKey : string);
 var
   R : TRegistry;
   FontStyleInt : byte;
   FS : TFontStyles;
 begin
   R:=TRegistry.Create;
   try
     FS:=Font.Style;
     Move(FS,FontStyleInt,1);
     R.OpenKey(SubKey,True);
     R.WriteString('Font Name',Font.name);
     R.WriteInteger('Color',Font.Color);
     R.WriteInteger('CharSet',Font.Charset);
     R.WriteInteger('Size',Font.Size);
     R.WriteInteger('Style',FontStyleInt);
   finally
     R.Free;
   end;
 end;
 
 function ReadFontFromRegistry(Font : TFont; SubKey : string) : boolean;
 var
   R : TRegistry;
   FontStyleInt : byte;
   FS : TFontStyles;
 begin
   R:=TRegistry.Create;
   try
     result:=R.OpenKey(SubKey,false);
     if not result then
       exit;
     Font.name:=R.ReadString('Font Name');
     Font.Color:=R.ReadInteger('Color');
     Font.Charset:=R.ReadInteger('CharSet');
     Font.Size:=R.ReadInteger('Size');
     FontStyleInt:=R.ReadInteger('Style');
     Move(FontStyleInt,FS,1);
     Font.Style:=FS;
   finally
     R.Free;
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if FontDialog1.Execute then
     SaveFontToRegistry(FontDialog1.Font, 'Delphi Kingdom\Fonts');
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 var
   NFont : TFont;
 begin
   NFont:=TFont.Create;
   if ReadFontFromRegistry(NFont,'Delphi Kingdom\Fonts') then
   begin
     //здесь добавить проверку - существует ли шрифт
     Label1.Font.Assign(NFont);
     NFont.Free;
   end;
 end;
 




TFrame. Несколько фреймов одного типа на форме

Автор: Vlad aka Freeman

Проблема в следующем: если положить на одну форму два фрейма одного типа, то в дизайне все нормально, а при создании формы во время выполнения может произойти ошибка: Component named xxxx already exists. Причина - баг в коде загрузки фрейма из DFM.

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

Чтобы такое не возникало, фреймы одного типа, размещенные на форме, должны иметь имена, отличные от ТипФреймаНомер, например, TMyFrame1 или TMyFrame5. Дайте фреймам другие имена, и форма будет создаваться нормально.

КОММЕНТАРИЙ

Описанный эффект возникает в случае, если один из нескольких экземпляров фрейма на форме имеет имя, соответствующее его типу, при отбрасывании первой "T". Например:


 Frame1: TFrame1; // причина проблемы
 Frame2: TFrame1;
 Frame3: TFrame1;
 

Но!

Во-первых, автоматический генератор кода в IDE (вероятно, зная об этой особенности - D5 SP1) дает имена вида:


 Frame11 : TFrame1;
 Frame12 : TFrame1;
 Frame13 : TFrame1;
 ...
 Frame21 : TFrame2;
 

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

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




Заголовок TGA-файла

OK, берем книжку 'Graphics File Formats, 2nd Edition' (форматы графических файлов) авторов David C. Kay & John R. Levine, и читаем формат заголовка файла для хранения изображения формата Targa.

Описание заголовка файла для изображения формата Targa
Смещение
Длина (в байтах)
Описание
0 1 Длина ID-поля (ID Field Length)
1 1 Тип цветовой карты (Color-map Type)
2 1 Тип изображения (Image Type)
      Информация о специфике цветовой карты (Color-map-specific Info)
3 2 Первое включение цветовой карты (First Color-map Entry)
5 2 Длина цветовой карты (Color-map Length)
7 1 Размер цветовой карты (Color-map Entry Size)
      Информация о специфике изображения (Image-specific Info)
8 2 Горизонтальная координата начала изображения (Image X Origin)
10 2 Вертикальная координата начала изображения (Image Y Origin)
12 2 Ширина изображения (Image Width)
14 2 Высота изображения (Image Height)
16 1 Бит на пиксел (Bits-Per-Pixel)
17 1 Биты дескриптора изображения (Image-Descriptor Bits)

Для изображений с разрешением True-color значение типа цветовой карты должно равняться нулю, в остальных случаях единице. В случае, когда цветовая карта присутствует, ее размер должен равняться значению 15, 16, 24 или 32. Для значений 15 и 16 каждая цветовая карта при загрузке использует 2 байта в формате:

Верхний байт    Нижний байт
 A RRRRR GG      GGG BBBBB  

где бит 'A' устанавливается в 0 для 15-битных цветовых величин. 24-битный размер карты хранится как три байта в следующем порядке: (B)lue (синий), (G)reen (зеленый), и (R)ed (красный). 32-битный размер цветовой карты использует четыре байта, ее порядок такой: (B)lue (синий), (G)reen (зеленый), (R)ed (красный) и значение атрибута - (A)ttribute.

Наконец, код, хранящий тип изображения (Image Type) должен содержать одно из следующих значений:

Код             Описание
 ----            -----------
 0               Изображение отсутствует
 1               Цветовая карта, без компрессии
 2               True-color, без компрессии
 3               Черно-белое, без компрессии
 9               Цветовая карта, RLE-компрессия
 10              True-color, RLE-компрессия
 11              Черно-белое, RLE-компрессия
Горизонтальная и вертикальная координата начала изображения (Image X & Y Origins) и размеры изображения (Image Width & Height) разъяснений не требуют. Бит на пиксел (Bits-Per-Pixel) обозначает количество битов, содержащихся в точке изображения и может быть равен значению 8, 16, 24, и 32.

Биыт дескриптора изображения (The Image Descriptor bytes) содержит несколько полей битов, которые содержат следующую информацию:

Биты            Описание
 ----            -----------
 0-3             Биты атрибутов (описаны ниже)
 4               Ориентация Слева-на-Право 0=Л/П 1=П/Л
 5               Ориентация Вехр/Низ 0=Н/В 1=В/Н
 6-7             Чередование линий 00H=Нет, 40H=2 линии, 80H=4 линии
Биты атрибутов используются для определения атрибутов цветов в цветовой карте или true-color пикселах. 0 - alpha-данные (alpha-канал) отсутствуют, 1 - игнорирование или неопределено, 2 - не определено, но должно быть сохранено, 3 - наличие alpha-данных и 4 - информация о пикселе уже была умножена на alpha-величину.

Файлы версии Targa 2.0 также имеют файловый колонтитул, который может содержать дополнительное изображение или комментарии. Эти файлы всегда заканчиваются строкой-терминатором 'TRUEVISION-TARGA.'. Так, если ваше Targa-изображение заканчивается значением 'TRUEVISION-TARGA.' + 00H, то вы можете извлечь восемь байтов до строки, чтобы найти начало расширенной области и месторасположение каталога сборки данного файла. Обычно файловый колонтитул версии 2.0 имеет следующий формат:

Формат файлового колонтитула Targa версии 2.0
Байт
Длина
Описание
0 4 32-битное смещение расширенной области
4 4 32-битное смещение каталога сборки
8 17 TRUEVISION-TARGA.
25 1 Двоичный ноль ($0)

Я не собираюсь давать полные описания каталога сборки и области расширения. Вместо этого я приведу описание "почтовой марки", которая может содержаться в формате Targa V2.0. Данная "марка"-иконка должна иметь размеры 64 X 64 пикселей, представляет собой уменьшенный образ изображения, может включаться в файл по желанию компоновщика и не является обязательной.

Область расширения
Смещение
Длина
Описание
0 2 Размер области расширения (должна быть 495)
2 41 Имя автора
43 81 Авторские комментарии
124 81 Авторские комментарии
205 81 Авторские комментарии
286 81 Авторские комментарии
367 2 Месяц создания
369 2 День создания
371 2 Год создания
... ... ...
482 4 Смещение в файле таблицы цветовой коррекции
486 4 Смещение в файле изображения "почтовой марки"
490 4 Смещение в файле таблицы чередования линий
494 1 Байты атрибутов

Данная "почтовая марка", при наличии, может быть использована вами непосредственно. Она хранится в виде несжатого изоюражения в том же цветовом формате (цветовой карте или True-color), как и исходное изображение.




Теория и практика использования RTTI

Билли Гейтс был в детстве yпpям и делал все наобоpот. Когда мать коpмила его кашей, она говоpила:
- Ешь кашy, тогда станешь большим и твеpдым. Hо Билли кашy не любил...

Delphi — это мощная среда визуальной разработки программ сочетающая в себе весьма простой и эффективный язык программирования, удивительный по быстроте компилятор и подкупающую открытость (в состав Delphi входят исходные тексты стандартных модулей и практически всех компонент библиотеки VCL). Однако, как и на солнце, так и в Delphi существуют пятна (на солнце черные, а в Delphi — белые), пятна недокументированных (или почти не документированных) возможностей. Одно из таких пятен — это информация о типах времени исполнения и методы работы с ней.

Информация о типах времени исполнения.(Runtime Type Information, RTTI) —это данные, генерируемые компилятором Delphi о большинстве объектов вашей программы. RTTI представляет собой возможность языка, обеспечивающее приложение информацией об объектах (его имя, размер экземпляра, указатели на класс-предок, имя класса и т. д.) и о простых типах во время работы программы. Сама среда разработки использует RTTI для доступа к значениям свойств компонент, сохраняемых и считываемых из dfm-файлов и для отображения их в Object Inspector,

Компилятор Delphi генерирует runtime информацию для простых типов, используемых в программе, автоматически. Для объектов, RTTI информация генерируется компилятором для свойств и методов, описанных в секции published в следующих случаях:

Объект унаследован от объекта, дня которого генерируется такая информация. В качестве примера можно назвать объект TPersistent.

Декларация класса обрамлена директивами компилятора {$M+} и {$M-}.

Необходимо отметить, что published свойства ограничены по типу данных. Они могут быть перечисляемым типом, строковым типом, классом, интерфейсом или событием (указатель на метод класса). Также могут использоваться множества (set), если верхний и нижний пределы их базового типа имеют порядковые значения между 0 и 31 (иначе говоря, множество должно помещаться в байте, слове или двойном слове). Также можно иметь published свойство любого из вещественных типов (за исключением Real48). Свойство-массив не может быть published. Все методы могут быть published, но класс не может иметь два или более перегруженных метода с одинаковыми именами. Члены класса могут быть published, только если они являются классом или интерфейсом.

Корневой базовый класс для всех VCL объектов и компонент, TObject, содержит ряд методов для работы с runtime информацией. Наиболее часто используемые из них приведены в таблице 1.

Наиболее часто используемые методы класса TObject для работы с RTTI

Метод Описание
ClassType Возвращает тип класса объекта. Вызывается неявно компилятором при определении типа объекта при использовании операторов is и as
ClassName Возвращает строку, содержащую название класса объекта. Например, для объекта типа TForm вызов этой функции вернет строку "TForm"
ClassInfo Возвращает указатель на runtime информацию объекта
InstanceSize Возвращает размер конкретного экземпляра объекта в байтах.
 

Таблица 1

Object Pascal предоставляет в распоряжение программиста два оператора, работа которых основана на неявном для программиста использовании RTTI информации. Это операторы is и as. Оператор is предназначен для проверки соответствия экземпляра объекта заданному объектному типу. Так, выражение вида:


 AObject is TSomeObjectType
 

является истинным в том случае, если объект AObject является экземпляром класса TSomeObjectType или одного из порожденных от него классов. Следует отметить, что определенная проверка происходит еще на этапе компиляции программы. если фактические объект и класс несовместимы, компилятор выдаст ошибку в этом операторе. Так, следующий программный код


 if Edit1 is TForm then
   ShowMessage('Враки!');
 

даже не будет пропущен компилятором, и он выдаст сообщение о не совместимости типов (разумеется, что Edit1 — это компонент типа TEdit):


 Incompatible types: 'TForm' and 'TEdit'.
 

Перейдем теперь к оператору as. Он введен в язык специально для приведения объектных типов. Посредством него можно рассматривать экземпляр объекта как принадлежащий к другому совместимому типу:


 AObject as TSomeObjectType
 

Использование оператора as отличается от обычного способа приведения типов


 TSomeObjectType(AObject)
 

наличием проверки на совместимость типов. Так при попытке приведения этого оператора с несовместимым типом он сгенерирует исключение EInvalidCast. Определенным недостатком операторов is и as является то, что присваиваемый фактически тип должен быть известен на этапе компиляции программы и поэтому на месте TSomeObjectType не может стоять переменная указателя на класс.

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


 var
   I: Integer;
 begin
   for I := 0 to ComponentCount - 1 do
     if Components[I] is TEdit then
       (Components[I] as TEdit).Text := '';
       { или так TEdit (Components[I]).Text := ''; }
 end;
 

Хочу обратить ваше внимание, а то, что стандартное приведение типа в данном примере предпочтительнее, поскольку в операторе if мы уже установили что компонент является объектом нужного нам типа и дополнительная проверка соответствия типов, проводимая оператором as, нам уже не нужна.

Первые шаги в понимании RTTI мы уже сделали. Теперь переходим к подробностям. Все основополагающие определения типов, основные функции и процедуры для работы с runtime информацией находятся в модуле TypInfo. Этот модуль содержит две фундаментальные структуры для работы с RTTI — TTypeInfo и TTypeData (типы указателей на них — PTypeInfo и PTypeData соответственно). Суть работы с RTTI выглядит следующим образом. Получаем указатель на структуру типа TTypeInfo (для объектов указатель можно получить, вызвав метод, реализованный в TObject, ClassInfo, а для простых типов в модуле System существует функция TypeInfo). Затем, посредством имеющегося указателя и вызова функции GetTypeData получаем указатель на структуру типа TTypeData. Далее используя оба указателя и функции модуля TypInfo творим маленькие чудеса. Для пояснения написанного выше рассмотрим пример получения текстового вида значений перечисляемого типа. Пусть, например, это будет тип TBrushStyle. Этот тип описан в модуле Graphics следующим образом:


 TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical,
   bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross);
 

Вот мы и попробуем получить конкретные значения этого типа в виде текстовых строк. Для этого создайте пустую форму. Поместите на нее компонент типа TListBox с именем ListBox1 и кнопку. Реализацию события OnClick кнопки замените следующим кодом:


 var
   ATypeInfo: PTypeInfo;
   ATypeData: PTypeData;
   I: Integer;
   S: string;
 begin
   ATypeInfo := TypeInfo(TBrushStyle);
   ATypeData := GetTypeData(ATypeInfo);
   for I := ATypeData.MinValue to ATypeData.MaxValue do
   begin
     S := GetEnumName(ATypeInfo, I);
     ListBox1.Items.Add(S);
   end;
 end;
 

Ну вот, теперь, когда на вооружении у нас есть базовые знания о противнике, чье имя, на первый взгляд выглядит непонятно и пугающее — RTTI настало время большого примера. Мы приступаем к созданию объекта опций для хранения различных параметров, использующего в своей работе мощь RTTI на полную катушку. Чем же примечателен, будет наш будущий класс? А тем, что он реализует сохранение в ini-файл и считывание из него свои свойства секции published. Его потомки будут иметь способность сохранять свойства, объявленные в секции published, и считывать их, не имея для этого никакой собственной реализации. Надо лишь создать свойство, а все остальное сделает наш базовый класс. Сохранение свойств организуется при уничтожении объекта (т.е. при вызове деструктора класса), а считывание и инициализация происходит при вызове конструктора класса. Декларация нашего класса имеет следующий вид:


 {$M+}
 TOptions = class(TObject)
   protected
     FIniFile: TIniFile;
     function Section: string;
     procedure SaveProps;
     procedure ReadProps;
   public
     constructor Create(const FileName: string);
     destructor Destroy; override;
 end;
 {$M-}
 

Класс TOptions является производным от TObject и по этому, что бы компилятор генерировал runtime информацию его надо объявлять директивами {$M+/-}. Декларация класса весьма проста и вызвать затруднений в понимании не должна. Теперь переходим к реализации методов.


 constructor TOptions.Create(const FileName: string);
 begin
   FIniFile:=TIniFile.Create(FileName);
   ReadProps;
 end;
 
 destructor TOptions.Destroy;
 begin
   SaveProps;
   FIniFile.Free;
   inherited Destroy;
 end;
 

Как видно реализация конструктора и деструктора тривиальна. В конструкторе мы создаем объект для работы с ini-файлом и организуем считывание свойств. В деструкторе мы в сохраняем значения свойств в файл и уничтожаем файловый объект. Всю нагрузку по реализации сохранения и считывания published-свойств несут методы SaveProps и ReadProps соответственно.


 procedure TOptions.SaveProps;
 var
   I, N: Integer;
   TypeData: PTypeData;
   List: PPropList;
 begin
   TypeData:= GetTypeData(ClassInfo);
   N:= TypeData.PropCount;
   if N <= 0 then
     Exit;
   GetMem(List, SizeOf(PPropInfo)*N);
   try
     GetPropInfos(ClassInfo,List);
     for I:= 0 to N - 1 do
       case List[I].PropType^.Kind of
         tkEnumeration, tkInteger:
           FIniFile.WriteInteger(Section, List[I]^.name,GetOrdProp(Self,List[I]));
         tkFloat:
           FIniFile.WriteFloat(Section, List[I]^.name, GetFloatProp(Self, List[I]));
         tkString, tkLString, tkWString:
           FIniFile.WriteString(Section, List[I]^.name, GetStrProp(Self, List[I]));
       end;
   finally
     FreeMem(List,SizeOf(PPropInfo)*N);
   end;
 end;
 
 
 procedure TOptions.ReadProps;
 var
   I, N: Integer;
   TypeData: PTypeData;
   List: PPropList;
   AInt: Integer;
   AFloat: Double;
   AStr: string;
 begin
   TypeData:= GetTypeData(ClassInfo);
   N:= TypeData.PropCount;
   if N <= 0 then
     Exit;
   GetMem(List, SizeOf(PPropInfo)*N);
   try
     GetPropInfos(ClassInfo, List);
     for I:= 0 to N - 1 do
       case List[I].PropType^.Kind of
         tkEnumeration, tkInteger:
         begin
           AInt:= GetOrdProp(Self, List[I]);
           AInt:= FIniFile.ReadInteger(Section, List[I]^.name, AInt);
           SetOrdProp(Self, List[i], AInt);
         end;
         tkFloat:
         begin
           AFloat:=GetFloatProp(Self,List[i]);
           AFloat:=FIniFile.ReadFloat(Section, List[I]^.name,AFloat);
           SetFloatProp(Self,List[i],AFloat);
         end;
         tkString, tkLString, tkWString:
         begin
           AStr:= GetStrProp(Self,List[i]);
           AStr:= FIniFile.ReadString(Section, List[I]^.name, AStr);
           SetStrProp(Self,List[i], AStr);
         end;
       end;
   finally
     FreeMem(List,SizeOf(PPropInfo)*N);
   end;
 end;
 
 function TOptions.Section: string;
 begin
   Result := ClassName;
 end;
 

Теперь, для проверки работоспособности, и отладки объекта опций создадим новое приложение и подключим к нему модуль, в котором описан и реализован объект TOptions. Ниже приведен программный код, иллюстрирующий создание наследника от класса TOptions и его использования в главной (и единственной) форме нашего тестового приложения интерфейсная часть выглядит так:


 TMainOpt = class(TOptions)
   private
     FText: string;
     FHeight: Integer;
     FTop: Integer;
     FWidth: Integer;
     FLeft: Integer;
     procedure SetText(const Value: string);
     procedure SetHeight(Value: Integer);
     procedure SetLeft(Value: Integer);
     procedure SetTop(Value: Integer);
     procedure SetWidth(Value: Integer);
   published
     property Text: string read FText write SetText;
     property Left: Integer read FLeft write SetLeft;
     property Top: Integer read FTop write SetTop;
     property Width: Integer read FWidth write SetWidth;
     property Height: Integer read FHeight write SetHeight;
 end;
 
 TForm1 = class(TForm)
     Edit1: TEdit;
     procedure Edit1Change(Sender: TObject);
   private
     FMainOpt: TMainOpt;
   public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
 end;
 

А вот и реализация:


 constructor TForm1.Create(AOwner: TComponent);
 var
   S: string;
 begin
   inherited Create(AOwner);
   S := ChangeFileExt(Application.ExeName, '.ini');
   FMainOpt := TMainOpt.Create(S);
   Edit1.Text := FMainOpt.Text;
 
   Left := FMainOpt.Left;
   Top := FMainOpt.Top;
   Width := FMainOpt.Width;
   Height := FMainOpt.Height;
 end;
 
 destructor TForm1.Destroy;
 begin
   FMainOpt.Left := Left;
   FMainOpt.Top := Top;
   FMainOpt.Width := Width;
   FMainOpt.Height := Height;
   FMainOpt.Free;
   inherited Destroy;
 end;
 
 { TMainOpt }
 
 procedure TMainOpt.SetText(const Value: string);
 begin
   FText := Value;
 end;
 
 procedure TForm1.Edit1Change(Sender: TObject);
 begin
   FMainOpt.Text := Edit1.Text;
 end;
 
 procedure TMainOpt.SetHeight(Value: Integer);
 begin
   FHeight := Value;
 end;
 
 procedure TMainOpt.SetLeft(Value: Integer);
 begin
   FLeft := Value;
 end;
 
 procedure TMainOpt.SetTop(Value: Integer);
 begin
   FTop := Value;
 end;
 
 procedure TMainOpt.SetWidth(Value: Integer);
 begin
   FWidth := Value;
 end;
 

В заключение своей статьи хочу сказать, что RTTI является недокументированной возможностью Object Pascal и поэтому информации на эту тему в справочной системе и электронной документации весьма мало. Наиболее легкодоступный способ изучить более подробно эту фишку — просмотр и изучение исходного текста модуля TypInfo.




Поточность TreeView

Автор: Mike Scott

На пустой форме у меня располагается TTreeView. Затем я сохраняю это в файле, используя WriteComponent. Это работает как положено; я могу из DOS c помощью команды "type" посмотреть двоичный файл и увидеть его содержимое, типа строк TTreeView и имя объекта. По крайней мере файл записывается и создается впечатление его "наполненности".

Затем я освобождаю компонент TTreeView, открываю поток, делаю ReadComponent и, затем, InsertControl. И получаю исключение "TreeView1 has no parent window" (TreeView1 не имеет родительского окна).

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

Попробуйте этот код:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   TreeView: TTreeView ;
 begin
   with TFileStream.Create( 'JUNK.STR', fmCreate ) do
     try
       WriteComponent( TreeView1 ) ;
       TreeView1.Name := 'TreeView' ;
       Position := 0 ;
       TreeView := TTreeView.Create( Self ) ;
       TreeView.Visible := false ;
       TreeView.Parent := Self ;
       ReadComponent( TreeView ) ;
       TreeView.Top := TreeView1.Top + TreeView1.Height + 10 ;
       TreeView.Visible := true ;
     finally
       Free ;
     end ;
 end;
 

Два небольших замечания:

  1. Убедитесь в отсутствии конфликта имен. Данный код делает форму владельцем второго TreeView и при ее освобождении разрушает компонент. Я просто переименовываю существующий TreeView перед загрузкой 'клона'.
  2. Я установил свойство visible в false перед установкой свойства parent, этим я предотвратил показ только что созданного TreeView до момента загрузки его из потока.



Как создавать потоки без класса TThread


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls;
 
 procedure incedit1; stdcall;
 procedure incedit2; stdcall;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     Edit1: TEdit;
     Edit2: TEdit;
     Button6: TButton;
     Button7: TButton;
     Button2: TButton;
     Button3: TButton;
     Button5: TButton;
     Button4: TButton;
     procedure Button1Click(Sender: TObject);
     procedure Button6Click(Sender: TObject);
     procedure Button7Click(Sender: TObject);
     procedure Button4Click(Sender: TObject);
     procedure Button5Click(Sender: TObject);
     procedure Button2Click(Sender: TObject);
     procedure Button3Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 var
   th1, th2: cardinal;
   h1, h2: integer;
 
 procedure incedit1;
 var
   i: integer;
 begin
   i := 0;
   while true do
   begin
     form1.edit1.text := inttostr(i);
     i := i + 1;
   end;
 end;
 
 procedure incedit2;
 var
   i: integer;
 begin
   i := 0;
   while true do
   begin
     form1.edit2.text := inttostr(i);
     i := i + 1;
   end;
 end;
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   h1 := beginthread(nil, 1024, @incedit1, nil, 0, th1);
   h2 := beginthread(nil, 1024, @incedit2, nil, 0, th2);
 end;
 
 procedure TForm1.Button6Click(Sender: TObject);
 begin
   terminatethread(h1, 0);
 end;
 
 procedure TForm1.Button7Click(Sender: TObject);
 begin
   terminatethread(h2, 0);
 end;
 
 procedure TForm1.Button4Click(Sender: TObject);
 begin
   resumethread(h1);
 end;
 
 procedure TForm1.Button5Click(Sender: TObject);
 begin
   resumethread(h2);
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   suspendthread(h1);
 end;
 
 procedure TForm1.Button3Click(Sender: TObject);
 begin
   suspendthread(h2);
 end;
 
 end.
 




Как создавать потоки без класса TThread 2


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls;
 
 procedure printh(p: pointer); stdcall;
 type
   TForm1 = class(TForm)
     Button1: TButton;
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure printh(p: pointer);
 begin
   TForm1(p).caption := 'Hello from thread';
   ExitThread(0);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   h1: cardinal;
 begin
   createthread(nil, 128, @printh, self, 0, h1);
 end;
 
 end.
 




Запись потока в BLOB-поле

Вся хитрость заключается в использовании StrPcopy (помещения вашей строки в PChar) и записи буфера в поток. Вы не сможете передать это в PChar непосредственно, поскольку ему нужен буфер, поэтому для получения необходимого размера буфера используйте <BufferName>[0] и StrLen().

Вот пример использования TMemoryStream и записи его в Blob-поле:


 var
   cString: string;
   oMemory: TMemoryStream;
   Buffer: PChar;
 begin
   cString := 'Ну, допустим, хочу эту строку!';
 
   { СОздаем новый поток памяти }
   oMemory := TMemoryStream.Create;
 
   {!! Копируем строку в PChar }
   StrPCopy(Buffer, cString);
 
   { Пишем =буфер= и его размер в поток }
   oMemory.Write(Buffer[0], StrLen(Buffer));
 
   {Записываем это в поле}
   < Blob / Memo / GraphicFieldName > .LoadFromStream(oMemory);
 
   { Необходимо освободить ресурсы}
   oMemory.Free;
 end;
 




Конвертируем TIF в PDF

Автор: Morten Ravn-Jonsen

...и написал Иисус конвертер water2wine, и стал раздавать его freeware...

Как-то раз получился TIF файл на несколько страниц и возникла необходимость конвертации его в PDF формат. Для использования такой возможности необходимо иметь полную версию Adobe Acrobat. Функция тестировалась на Adobe Acrobat 4.0.

Сперва Вам необходимо импортировать элементы управления Acrobat AxtiveX.

  1. Выберите Component -> Import ActiveX Control
  2. Выберите Acrobat Control for ActiveX и нажмите install
  3. Выберите пакет ActiveX control для инсталяции
  4. Добавьте PDFlib_tlb в Ваш проект. Этот файл находится в директории Borland\Delphi5\Imports.

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

Вот пример её вызова:


 if not TifToPDF('c:\test.tif', 'c:\test.pdf') then
   Showmessage('Could not convert');
 

Функция TifToPdf:


 function TifToPDF(TIFFilename, PDFFilename: string): boolean;
 var
   AcroApp: variant;
   AVDoc: variant;
   PDDoc: variant;
   IsSuccess: Boolean;
 begin
   result := false;
   if not fileexists(TIFFilename) then
     exit;
   try
     AcroApp := CreateOleObject('AcroExch.App');
     AVDoc := CreateOleObject('AcroExch.AVDoc');
     AVDoc.Open(TIFFilename, '');
     AVDoc := AcroApp.GetActiveDoc;
     if AVDoc.IsValid then
     begin
       PDDoc := AVDoc.GetPDDoc;
       PDDoc.SetInfo ('Title', '');
       PDDoc.SetInfo ('Author', '');
       PDDoc.SetInfo ('Subject', '');
       PDDoc.SetInfo ('Keywords', '');
       result := PDDoc.Save(1 or 4 or 32, PDFFilename);
       PDDoc.Close;
     end;
     AVDoc.Close(True);
     AcroApp.Exit;
   finally
     VarClear(PDDoc);
     VarClear(AVDoc);
     VarClear(AcroApp);
   end;
 end;
 




TImageList. Не отображаются иконки на контролах

Не отображаются картинки на тулбарах, кнопках, меню, и т.д. - везде, где используется TImageList для хранения массива изображений. Искажение цветов при использовании 256-цветных картинок в палитровом видеорежиме.

ТИПОВЫЕ РЕШЕНИЯ.
  • Не использовать TImageList, если это возможно.
  • Не хранить содержимое TImageList в ресурсе формы, а загружать в runtime из подготовленной bitmap или ресурса.
  • Обновить версию системной библиотеки comctl32.dll.



Как сделать картинки в TImageList прозрачными


 procedure TForm1.Button1Click(Sender: TObject);
 var
     bm : TBitmap;
     il : TImageList;
 begin
     bm := TBitmap.Create;
     bm.LoadFromFile('C:\DownLoad\TEST.BMP');
     il := TImageList.CreateSize(bm.Width,bm.Height);
     il.DrawingStyle := dsTransparent;
     il.Masked := true;
     il.AddMasked(bm, clRed);
     il.Draw(Form1.Canvas, 0, 0, 0);
     bm.Free;
     il.Free;
 end;
 




TImage - эффект плавного перехода

Автор: David C. Ullrich

Сказал админ: "Бывает все, сынок"
Когда уже не сможешь патчить прог,
Когда придешь домой в конце пути
По шею бошку в ПИВО опусти

...существует ли для этого эффекта какой-либо алгоритм генерации изображений вместо использования кисточки?

Я был скептически настроен к механизму использования кистей, чтобы получить что-либо похожее на эффект перехода/ухода ("fade") по сравнению со стеркой ("wipe"), но вчера вечером я нашел следующее решение, которое делает невероятное - осуществляет плавный переход от одного изображения к другому:


 procedure WaitAWhile(n: longint);
 var
   StartTime: longint;
 begin
   StartTime := timeGetTime;
   while timeGetTime < StartTime + n do
     ;
 end;
 
 procedure TForm1.Image1Click(Sender: TObject);
 var
   BrushBmp, BufferBmp, Buffer2Bmp, ImageBmp, Image2Bmp: TBitmap;
   j, k, row, col: longint;
 begin
   row := 0;
   col := 0;
   BrushBmp := TBitmap.Create;
   with BrushBmp do
   begin
     Monochrome := false;
     Width := 8;
     Height := 8;
   end;
   imageBmp := TBitmap.create;
   imagebmp.loadfromfile('c:\huh.bmp');
   image2bmp := TBitmap.Create;
   image2bmp.LoadFromFile('c:\whatsis.bmp');
   {При 256 цветах лучше иметь ту же самую палитру!}
   BufferBmp := TBitmap.Create;
   with BufferBmp do
   begin
     Height := 200;
     Width := 200;
     canvas.brush.bitmap := TBitmap.Create;
   end;
   Buffer2Bmp := TBitmap.Create;
   with Buffer2Bmp do
   begin
     Height := 200;
     Width := 200;
     canvas.brush.bitmap := TBitmap.Create;
   end;
   for k := 1 to 16 do
   begin
     WaitAWhile(0); {Для пентиума необходимо добавить задержку}
     for j := 0 to 3 do
     begin
       row := (row + 5) mod 8;
       col := (col + 1) mod 8;
       if row = 0 then
         col := (col + 1) mod 8;
       BrushBmp.canvas.Pixels[row, col] := clBlack;
     end;
     with BufferBmp do
     begin
       canvas.copymode := cmSrcCopy;
       canvas.brush.bitmap.free;
       canvas.brush.style := bsClear;
       canvas.brush.bitmap := TBitmap.Create;
       canvas.brush.bitmap.Assign(BrushBmp);
       canvas.Rectangle(0, 0, 200, 200);
       canvas.CopyMode := cmMergeCopy;
       canvas.copyrect(rect(0, 0, 200, 200), imageBmp.canvas,
         rect(0, 0, 200, 200));
     end;
     with Buffer2Bmp do
     begin
       canvas.copymode := cmSrcCopy;
       canvas.brush.bitmap.free;
       canvas.brush.style := bsClear;
       canvas.brush.bitmap := TBitmap.Create;
       canvas.brush.bitmap.Assign(BrushBmp);
       canvas.Rectangle(0, 0, 200, 200);
       canvas.copymode := cmSrcErase;
       canvas.copyrect(rect(0, 0, 200, 200), image2bmp.canvas,
         rect(0, 0, 200, 200));
     end;
     BufferBmp.Canvas.CopyMode := cmSrcPaint;
     BufferBmp.Canvas.Copyrect(rect(0, 0, 200, 200),
       Buffer2Bmp.Canvas, rect(0, 0, 200, 200));
     canvas.copymode := cmSrcCopy;
     canvas.copyrect(rect(0, 0, 200, 200), BufferBmp.Canvas,
       rect(0, 0, 200, 200));
   end;
 
   BufferBmp.canvas.brush.bitmap.free;
   Buffer2Bmp.canvas.brush.bitmap.free;
   BrushBmp.Free;
   BufferBmp.Free;
   Buffer2Bmp.Free;
   ImageBmp.Free;
   image2Bmp.Free;
 end;
 

Комментарии: На Pentium I я реально использую 64 кисточки, изменив приведенные выше строки на следующие:


 for k:= 1 to 64 do
 begin
   WaitAWhile(50);
   for j:=0 to 0 do
 

При организации указанной задержки возможно получение плавного перехода.

Заполняя кисть в другом порядке, вы можете получить ряд других эффектов, но приведенная выше версия единственная, которую мне удалось получить максимально похожей на эффект перехода, но вы можете, скажем, написать:


 begin
   row:=(row+1) mod 8;
   (*col:=(col+1) mod 8;*)
   if row=0 then
     col:=(col+1) mod 8;
 

и получить своего рода эффект перехода типа "venetian-blind wipe" (дословно - стерка венецианского хрусталя).

Вопрос: Я чуствую, что я делаю что-то неправильно, существует какая-то хитрость с кистью. Мне нужно все четыре строчки:


 canvas.brush.bitmap.free;
 canvas.brush.style:=bsClear;
 canvas.brush.bitmap:=TBitmap.Create;
 canvas.brush.bitmap.Assign(BrushBmp);
 

чтобы все работало правильно; но я совсем не понимаю, почему первые три строки являются обязательными, но если я их выкидываю, Assign сработывает только один раз(!?!?!). Это реально работает? Есть способ другого быстрого назначения brush.bitmaps? (В документации в качестве примера указано на Brush.Bitmap.LoadFromFile, но должно быть лучшее решение. Хорошо, допустим приведенный способ лучший, но он кажется неправильным...)




Засечь время


И-нетчика на улице спросили:
- Который час?
- Если по Гринвичу - то 12, если по Московскому - то не знаю, нет часов.

Засекание обычно нужно в двух случаях: самому программисту – узнать, как программа работает быстрее, или для информирования пользователя, сколько программа уже трудится.

Для засекания времени удобнее всего использовать функцию GetTickCount, но нельзя забывать о ее погрешности при измерении очень коротких промежутков времени, и о том, что программы в Windows работают с непостоянной скоростью. Поэтому не стоит засекать быстрые процессы, и не стоит делать выводы о каком-то алгоритме после одного тестирования. И еще. Если вы тестируете алгоритм, то поставьте его в цикл, выполнив его, например, тысячу раз, а потом получившееся время делите на тысячу. Так точнее. Эта программа засекает, сколько времени меняется цвет точек окна в этой программе.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   i, t: integer;
 begin
   t := GetTickCount;
   randomize;
   for i := 0 to 100000 do
     Form1.Canvas.Pixels[i mod Form1.ClientWidth,
     i div Form1.ClientWidth] :=
     RGB(random(255), random(255), random(255));
   Form1.Caption := IntToStr(GetTickCount - t);
 end;
 




Прокрутка текста заголовка


 var
   a: string;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   a := 'Look at here !...';
 end;
 
 procedure TForm1.Timer1Timer(Sender: TObject);
 var
   i: Integer;
 begin
   Application.Title := a;
   Form1.Caption     := a;
   for i := 1 to (Length(a) - 1) do
     a[i] := Application.Title[i + 1];
   a[Length(a)] := Application.Title[1];
 end;
 




Комбинация TLabel и TEdit

- Ваш компьютеp не загpужается. Мы тpебуем, чтоб сменили пpоцессоp! А в синей таблице (имеется в виду NC) были какие-то с pешётками (имеются в виду защищённые системные файлы). Наш сын хоpошо в этом pазбиpается, они в техникуме все компьютеpы пpоходят. Он сказал, что это сбои на винчестеpе, но ему удалось от них избавиться...


 unit Editlbl1;
 
 interface
 
 uses
 
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, stdctrls;
 
 type
 
   TLabelEdit = class(TWinControl)
   private
     { Private declarations }
     FEdit: TEdit;
     FLabel: TLabel;
     function GetLabelCaption: string;
     procedure SetLabelCaption(LabelCaption: string);
     function GetEditText: string;
     procedure SetEditText(EditText: string);
   protected
     { Protected declarations }
   public
     { Public declarations }
     constructor Create(AOwner: TComponent); override;
   published
     property LabelCaption: string read GetLabelCaption write SetLabelCaption;
     property EditText: string read GetEditText write SetEditText;
     property Left;
     property Top;
     property Width;
     property Height;
     property Text;
     property Font;
     { Можете опубликовать другие, необходимые вам свойства. }
     { Published declarations }
   end;
 
 procedure Register;
 
 implementation
 
 constructor TLabelEdit.Create(AOwner: TComponent);
 begin
 
   inherited Create(AOwner);
 
   FEdit := TEdit.Create(self);
   FLabel := TLabel.Create(self);
 
   with FLabel do
   begin
     Width := FEdit.Width;
     visible := true;
     Parent := self;
     Caption := 'LabelEdit';
   end;
 
   with FEdit do
   begin
     Top := FLabel.Height + 2;
     Parent := self;
     Visible := true;
   end;
 
   Top := 0;
   Left := 0;
   Width := FEdit.Width;
   Height := FEdit.Height + FLabel.Height;
   Visible := true;
 end;
 
 function TLabelEdit.GetLabelCaption: string;
 begin
 
   Result := FLabel.Caption;
 end;
 
 procedure TLabelEdit.SetLabelCaption(LabelCaption: string);
 begin
 
   FLabel.Caption := LabelCaption;
 end;
 
 function TLabelEdit.GetEditText: string;
 begin
 
   Result := FEdit.Text;
 end;
 
 procedure TLabelEdit.SetEditText(EditText: string);
 begin
 
   FEdit.Text := EditText;
 end;
 
 procedure Register;
 begin
 
   RegisterComponents('Test', [TLabelEdit]);
 end;
 
 end.
 




TLabel и TEdit без контейнера

Автор: Mike Scott

Один компьютерщик рассказывает другому:
- Представляешь,вчера возвращаюсь с работы чуть раньше обычного, а у жены в постели - незнакомый мужик. И глаза у обоих хитрые-хитрые... Я сразу неладное заподозрил,кинулся к компу, пытаюсь выйти в Интернет - а они, с%ки, пароль сменили...

При размещении на форме, создается TLabel, расположенный выше поля редактирования. При перемещении поля редактирования, TLabel "следует" за ним. При удалении поля редактирования, TLabel также удаляется. Имеется свойство LabelCaption, так что вы можете редактировать заголовок Tlabel. Вероятно вам потребуются и другие свойства TLabel, типа Font, но этот код только демонстрирует технологию, так что развивайте его по своему усмотрению.


 unit LblEdit;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 
 type
   TLabelEdit = class(TEdit)
   private
     FLabel: TLabel;
     procedure WMMove(var Msg: TWMMove); message WM_MOVE;
   protected
     procedure SetParent(Value: TWinControl); override;
     function GetLabelCaption: string; virtual;
     procedure SetLabelCaption(const Value: string); virtual;
   public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
   published
     property LabelCaption: string read GetLabelCaption write
       SetLabelCaption;
 
   end;
 
 procedure Register;
 
 implementation
 
 constructor TLabelEdit.Create(AOwner: TComponent);
 
 begin
   inherited Create(AOwner);
 
   { создаем TLabel }
   FLabel := TLabel.Create(nil);
   FLabel.Caption := 'Edit label';
 end;
 
 procedure TLabelEdit.SetParent(Value: TWinControl);
 
 begin
   { убеждаемся, что TLabel имеет того же родителя что и TEdit }
   if (Owner = nil) or not (csDestroying in Owner.ComponentState) then
     FLabel.Parent := Value;
   inherited SetParent(Value);
 end;
 
 destructor TLabelEdit.Destroy;
 
 begin
   if (FLabel <> nil) and (FLabel.Parent = nil) then
     FLabel.Free;
   inherited Destroy;
 end;
 
 function TLabelEdit.GetLabelCaption: string;
 
 begin
   Result := FLabel.Caption;
 end;
 
 procedure TLabelEdit.SetLabelCaption(const Value: string);
 
 begin
   FLabel.Caption := Value;
 end;
 
 procedure TLabelEdit.WMMove(var Msg: TWMMove);
 
 begin
   inherited;
 
   { заставляем TLabel 'прилипнуть' к верху TEdit }
   if FLabel <> nil then
     with FLabel do
       SetBounds(Msg.XPos, Msg.YPos - Height, Width, Height);
 end;
 
 procedure Register;
 begin
   RegisterComponents('Samples', [TLabelEdit]);
 end;
 
 initialization
   { Мы используем TLabel, поэтому для обеспечения
   "поточности" необходима регистрация }
   RegisterClass(TLabel);
 end.
 




Как узнать, по какой колонке был клик в TListView

Метод GetItemAt позволяет получить координаты ListItem, по которой был клик, но только для первой колонки TListView. Если нужно узнать по какому элементу из другой колонки кликнул пользователь, то прийдётся объявить новый метод в наследованном классе:


 uses ComCtrls;
 
 type
   TListViewX = class(TListView)
   public
     function GetItemAtX(X, Y: integer; var Col: integer): TListItem;
   end;
 
 implementation
 
 function TListViewX.GetItemAtX(X, Y: integer;
   var Col: integer): TListItem;
 var
   i, n, RelativeX, ColStartX: Integer;
   ListItem: TlistItem;
 begin
   Result := GetItemAt(X, Y);
   if Result <> nil then begin
     Col := 0; // Первая колонка
   end else if (ViewStyle = vsReport)
     and (TopItem <> nil) then begin
     // Первая, попробуем найти строку
     ListItem := GetItemAt(TopItem.Position.X, Y);
     if ListItem <> nil then begin
       // Теперь попробуем найти колонку
       RelativeX := X - ListItem.Position.X - BorderWidth;
       ColStartX := Columns[0].Width;
       n := Columns.Count - 1;
       for i := 1 to n do begin
         if RelativeX < ColStartX then break;
         if RelativeX <= ColStartX +
           StringWidth(ListItem.SubItems[i - 1]) then
         begin
           Result := ListItem;
           Col := i;
           break;
         end; //if
         Inc(ColStartX, Columns[i].Width);
       end; //for
     end; //if
   end; //if
 end;
 

А вот так выглядит событие MouseDown:


 procedure TForm1.ListView1MouseDown(Sender: TObject;
   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
 var
   col: integer;
   li: TListItem;
 begin
   li := TListViewX(ListView1).GetItemAtX(x, y, col);
   if li <> nil then
     ShowMessage('Column #' + IntToStr(col));
 end;
 




Искать текст в TListView

Заходит как то программист в комп.магазин долго ходил смотрел всё высматривал потом подходит к продавщице и просит посмотреть каталог, потом минуту спустя спрашивает:
- Извинити это у вас цены или номера ICQ???


 // Call FindCaption Method to search for a list view item labeled by the 
 // string specified as the Value parameter 
 
 
 // Syntax: 
 
 function FindCaption(StartIndex: Integer; Value: string;
   Partial, Inclusive, Wrap: Boolean): TListItem;
 
 
 // Example, Beispiel: 
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   lvItem: TListItem;
 begin
   lvItem := ListView1.FindCaption(0,      // StartIndex: Integer; 
                                   '99',   // Search string: string; 
                                   True,   // Partial, 
                                   True,   // Inclusive 
                                   False); // Wrap  : boolean; 
   if lvItem <> nil then
   begin
     ListView1.Selected := lvItem;
     lvItem.MakeVisible(True);
     ListView1.SetFocus;
   end;
 end;
 
 
 // To search for a list view subitem (also for items), use this function: 
 
 {
   Search for text in a listview item
   @Param lv is the listview, supposed to be in vaReport mode
   @Param S is the text to search for
   @Param column is the column index for the column to search , 0-based
   @Returns the found listview item, or Nil if none was found
   @Precondition  lv  nil, lv in report mode if column  0, S not empty
   @Desc The search is case-insensitive and will only match on the
   complete column content. Use AnsiContainsText instead of AnsiCompareText
   to match on a substring in the columns content.
   Created 14.10.2001 by P. Below
 }
 
 function FindListViewItem(lv: TListView; const S: string; column: Integer): TListItem;
 var
   i: Integer;
   found: Boolean;
 begin
   Assert(Assigned(lv));
   Assert((lv.viewstyle = vsReport) or (column = 0));
   Assert(S <> '');
   for i := 0 to lv.Items.Count - 1 do
   begin
     Result := lv.Items[i];
     if column = 0 then
       found := AnsiCompareText(Result.Caption, S) = 0
     else if column > 0 then
       found := AnsiCompareText(Result.SubItems[column - 1], S) = 0
     else
       found := False;
     if found then
       Exit;
   end;
   // No hit if we get here 
   Result := nil;
 end;
 
 // Example call: 
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   lvItem: TListItem;
 begin
   // Search subitem[0] for text from edit1 
   // in der Spalte subitem[0] den Text aus Edit1 suchen 
   lvItem := FindListViewItem(ListView1, Edit1.Text, 1);
   // if found, then show the item 
   // falls item gefunden, dann anzeigen 
   if lvItem <> nil then
   begin
     ListView1.Selected := lvItem;
     lvItem.MakeVisible(True);
     ListView1.SetFocus;
   end;
 end;
 
 
 // Function to search items and select if found 
 
 procedure LV_FindAndSelectItems(lv: TListView; const S: string; column: Integer);
 var
   i: Integer;
   found: Boolean;
   lvItem: TListItem;
 begin
   Assert(Assigned(lv));
   Assert((lv.ViewStyle = vsReport) or (column = 0));
   Assert(S <> '');
   for i := 0 to lv.Items.Count - 1 do
   begin
     lvItem := lv.Items[i];
     if column = 0 then
       found := AnsiCompareText(lvItem.Caption, S) = 0
     else if column > 0 then
     begin
       if lvItem.SubItems.Count >= Column then
         found := AnsiCompareText(lvItem.SubItems[column - 1], S) = 0
       else
         found := False;
     end
     else
       found := False;
     if found then
     begin
       lv.Selected := lvItem;
     end;
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   lvItem: TListItem;
 begin
   // in der Spalte subitem[0] den Text aus Edit1 suchen 
   LV_FindAndSelectItems(ListView1, Edit1.Text, 1);
   ListView1.SetFocus;
 end;
 




Файл типа TList

Ок, но это не так просто, как кажется. Тем не менее, с помощью некоторых людей из конференции, мне удалось сделать это и придать коду законченный вид. Ниже приведен исходный код для Toverheadmap...

Обратите внимание на методы объекта ReadData и WriteData, используемые для его записи на диск, и методы SaveToFile и LoadFromFile самого TList. Правильным было бы сделать их более совместимыми (общими), но на это пока у меня не хватило времени. (Т.е., TList должен был бы восстанавливать/сохранять любой объект с помощью метода readdata/writedata.)


 unit Charactr;
 
 interface
 
 uses
 
   Graphics, StdCtrls, Classes, Sysutils, Winprocs, Ohmap, ohmstuff;
 
 type
 
   TMapCharacterList = class(TList)
   private
     FMap: TOverHeadMap;
   public
     procedure RenderVisibleCharacters; virtual;
     procedure Savetofile(const filename: string);
     procedure Loadfromfile(const filename: string);
     procedure Clear;
     destructor Destroy; override;
     property MapDisp: TOverHeadMap read FMap write FMap;
   end;
 
   TFrameStore = class(TList)
     procedure WriteData(Writer: Twriter); virtual;
     procedure ReadData(Reader: TReader); virtual;
     procedure Clear;
   end;
 
   TMapCharacter = class(TPersistent)
   private
     FName: string;
     FMap: TOverHeadMap;
     FFrame: Integer;
     FFramebm, FFrameMask, FWorkBuf: TBitmap;
     FFrameStore, FMaskStore: TFrameStore;
     FXpos, FYpos, FZpos: Integer;
     FTransColor: TColor;
     FVisible, FFastMode, FIsClone, FRedrawBackground: Boolean;
     procedure SetFrame(num: Integer);
     function GetOnScreen: Boolean;
     procedure SetVisible(vis: Boolean);
     procedure MakeFrameMask(trColor: TColor);
     procedure MakeFrameMasks; {Для переключения в быстрый режим...}
     procedure ReplaceTransColor(trColor: TColor);
     procedure SetXPos(x: Integer);
     procedure SetYPos(y: Integer);
     procedure SetZPos(z: Integer);
     procedure SetFastMode(fast: Boolean);
   public
     constructor Create(ParentMap: TOverheadmap); virtual;
     destructor Destroy; override;
     property Name: string read FName write FName;
     property Fastmode: Boolean read FFastMode write SetFastMode;
     property FrameStore: TFrameStore read FFrameStore write FFramestore;
     property MaskStore: TFrameStore read FMaskStore write FMaskStore;
     property Frame: integer read FFrame write SetFrame;
     property Framebm: TBitmap read FFramebm;
     property FrameMask: TBitmap read FFrameMask;
     property TransColor: TColor read FTransColor write FTransColor;
     property Xpos: Integer read FXpos write SetXpos;
     property YPos: Integer read FYpos write SetYpos;
     property ZPos: Integer read FZpos write SetZpos;
     property Map: TOverHeadMap read FMap write FMap;
     property OnScreen: Boolean read GetOnScreen;
     property Visible: Boolean read FVisible write SetVisible;
     property IsClone: Boolean read FIsClone write FIsClone;
     property RedrawBackground: Boolean read FRedrawBackground write
       FRedrawBackground;
 
     procedure Render; virtual;
     procedure RenderCharacter(mapcoords: Boolean; cxpos, cypos: Integer; mask,
       bm,
       wb: TBitmap); virtual;
 
     procedure Clone(Source: TMapCharacter); virtual;
 
     procedure SetCharacterCoords(x, y, z: Integer); virtual;
     procedure WriteData(Writer: Twriter); virtual;
     procedure ReadData(Reader: TReader); virtual;
   end;
 
 implementation
 
 constructor TMapCharacter.Create(ParentMap: TOverheadmap);
 begin
 
   inherited Create;
   FIsClone := False;
   FFramebm := TBitMap.create;
   FFrameMask := TBitmap.Create;
   FWorkbuf := TBitMap.Create;
   if not (FIsClone) then
     FFrameStore := TFrameStore.Create;
 
   FTransColor := clBlack;
   FFastMode := False;
   FMap := ParentMap;
 end;
 
 destructor TMapCharacter.Destroy;
 var
   a, b: Integer;
 begin
 
   FFramemask.free;
   FFramebm.free;
   FWorkBuf.Free;
   if not (FIsClone) then
   begin
     FFrameStore.Clear;
     FFrameStore.free;
   end;
 
   if (MaskStore <> nil) and not (FIsClone) then
   begin
     MaskStore.Clear;
     MaskStore.Free;
   end;
   inherited Destroy;
 end;
 
 {
 
 Данная процедура копирует важную информацию из символа в себя
 ...
 
 Стартуем невидимое клонирование, с нулевыми координатами карты.
 }
 
 procedure TMapCharacter.Clone(Source: TMapCharacter);
 begin
 
   FName := Source.Name;
   FFastMode := Source.FastMode;
   FFrameStore := Source.FrameStore;
   FMaskStore := Source.MaskStore;
   FTransColor := Source.TransColor;
   FMap := Source.Map;
   FVisible := False;
 
   Frame := Source.Frame; {Ищем фрейм триггера.}
 
   FIsClone := True;
 end;
 
 procedure TMapCharacter.SetXPos(x: Integer);
 begin
 
   Map.Redraw(xpos, ypos, zpos, -1);
   FXpos := x;
   Render;
 end;
 
 procedure TMapCharacter.SetYPos(y: Integer);
 begin
 
   Map.Redraw(xpos, ypos, zpos, -1);
   FYPos := y;
   Render;
 end;
 
 procedure TMapCharacter.SetZPos(z: Integer);
 begin
 
   Map.Redraw(xpos, ypos, zpos, -1);
   FZpos := z;
   Render;
 end;
 
 procedure TMapCharacter.SetCharacterCoords(x, y, z: Integer);
 begin
 
   Map.Redraw(xpos, ypos, zpos, -1);
   Fxpos := x;
   Fypos := y;
   Fzpos := z;
   Render;
 end;
 
 procedure TMapCharacter.SetFrame(num: Integer);
 begin
 
   if (num <= FFrameStore.count - 1) and (num > -1) then
   begin
     FFrame := num;
     FFramebm.Assign(TBitmap(FFrameStore.items[num]));
     if Ffastmode = false then
     begin
       FFrameMask.Width := FFramebm.width;
       FFrameMask.Height := FFramebm.height;
       FWorkBuf.Height := FFramebm.height;
       FWorkBuf.Width := FFramebm.width;
       makeframemask(TransColor);
       replacetranscolor(TransColor);
     end
     else
     begin
       FWorkBuf.Height := FFramebm.height;
       FWorkBuf.Width := FFramebm.width;
       FFrameMask.Assign(TBitmap(FMaskStore.items[num]));
     end;
   end;
 end;
 
 procedure TMapCharacter.MakeFrameMask(trColor: TColor);
 var
   testbm1, testbm2: TBitmap;
   trColorInv: TColor;
 begin
 
   testbm1 := TBitmap.Create;
   testbm1.width := 1;
   testbm1.height := 1;
   testbm2 := TBitmap.Create;
   testbm2.width := 1;
   testbm2.height := 1;
   testbm1.Canvas.Pixels[0, 0] := trColor;
   testbm2.Canvas.CopyMode := cmSrcInvert;
   testbm2.Canvas.Draw(0, 0, testbm1);
   trColorInv := testbm2.Canvas.Pixels[0, 0];
   testbm1.free;
   testbm2.free;
   with FFrameMask.Canvas do
   begin
     Brush.Color := trColorInv;
     BrushCopy(Rect(0, 0, FFrameMask.Width, FFrameMask.Height), FFramebm,
       Rect(0, 0, FFramebm.Width, FFramebm.Height), trColor);
     CopyMode := cmSrcInvert;
     Draw(0, 0, FFramebm);
   end;
 end;
 
 procedure TMapCharacter.ReplaceTransColor(trColor: TColor);
 begin
 
   with FFramebm.Canvas do
   begin
     CopyMode := cmSrcCopy;
     Brush.Color := clBlack;
     BrushCopy(Rect(0, 0, FFramebm.Width, FFramebm.Height), FFramebm,
       Rect(0, 0, FFramebm.Width, FFramebm.Height), trColor);
   end;
 end;
 
 function TMapCharacter.GetOnScreen: Boolean;
 var
   dispx, dispy: Integer;
 begin
 
   dispx := Map.width div map.tilexdim;
   dispy := Map.height div map.tileydim;
   if (xpos >= Map.xpos) and (xpos <= map.xpos + dispx) and (ypos >= map.ypos)
     and
     (ypos >= map.ypos + dispy) then
 
     result := true;
 end;
 
 procedure TMapCharacter.SetVisible(vis: Boolean);
 begin
 
   if vis and OnScreen then
     Render;
   FVisible := vis;
 end;
 
 procedure TMapCharacter.SetFastMode(fast: Boolean);
 begin
 
   if fast <> FFastMode then
   begin
     if fast = true then
     begin
       FMaskStore := TFrameStore.Create;
       MakeFrameMasks;
       FFastMode := True;
       frame := 0;
     end
     else
     begin
       FMaskStore.Free;
       FFastMode := False;
     end;
   end;
 end;
 
 procedure TMapCharacter.MakeFrameMasks;
 var
   a: Integer;
   bm: TBitMap;
 begin
 
   if FFrameStore.count > 0 then
   begin
     for a := 0 to FFrameStore.Count - 1 do
     begin
       Frame := a;
       bm := TBitMap.create;
       bm.Assign(FFrameMask);
       FMaskStore.add(bm);
     end;
   end;
 end;
 
 procedure TMapCharacter.Render;
 var
   x, y: Integer;
 begin
 
   if visible and onscreen then
     RenderCharacter(true, xpos, ypos, FFramemask, FFramebm, FWorkbuf);
 end;
 
 procedure TMapCharacter.RenderCharacter(mapcoords: Boolean; cxpos, cypos:
   Integer; mask, bm, wb: TBitmap);
 var
   x, y: Integer;
 begin
 
   if map.ready then
   begin
     {
     Если пользователь определил это в mapcoords, то в первую
     очередь перерисовываем секцию(и). Если нет, делает это он.
     }
     if mapcoords then
     begin
       if FRedrawBackground then
         Map.redraw(cxpos, cypos, FMap.zpos, -1);
       wb.Canvas.Draw(0, 0, TMapIcon(FMap.Iconset[map.zoomlevel].items
         [FMap.Map.Iconat(cxpos, cypos, Map.zpos)]).image);
 
       x := (cxpos - Map.xpos) * FMap.tilexdim;
       y := (cypos - Map.ypos) * FMap.tileydim;
     end
     else
       wb.Canvas.Copyrect(rect(0, 0, FMap.tilexdim, FMap.tileydim), FMap.
         Screenbuffer.canvas, rect(x, y, x + FMap.tilexdim,
 
         y + FMap.tileydim));
 
     with wb do
     begin
       Map.Canvas.CopyMode := cmSrcAnd;
       Map.Canvas.Draw(0, 0, Mask);
       Map.Canvas.CopyMode := cmSrcPaint;
       Map.Canvas.Draw(0, 0, bm);
       Map.Canvas.Copymode := cmSrcCopy;
     end;
     Map.Canvas.CopyRect(Rect(x, y, x + FMap.tilexdim, y + FMap.tileydim), wb.
       canvas,
 
       Rect(0, 0, FMap.tilexdim, FMap.tileydim));
   end;
 end;
 
 procedure TMapCharacter.WriteData(Writer: TWriter);
 begin
 
   with Writer do
   begin
     WriteListBegin;
     WriteString(FName);
     WriteBoolean(FFastMode);
     WriteInteger(TransColor);
     FFrameStore.WriteData(Writer);
     if FFastMode then
       FMaskStore.WriteData(Writer);
     WriteListEnd;
   end;
 end;
 
 procedure TMapCharacter.ReadData(Reader: TReader);
 begin
 
   with Reader do
   begin
     ReadListBegin;
     Fname := ReadString;
     FFastMode := ReadBoolean;
     TransColor := ReadInteger;
     FFrameStore.ReadData(Reader);
     if FFastMode then
     begin
       FMaskStore := TFrameStore.Create;
       FMaskStore.ReadData(Reader);
     end;
     ReadListEnd;
   end;
 end;
 
 procedure TMapCharacterList.RenderVisibleCharacters;
 var
   a: Integer;
 begin
 
   for a := 0 to count - 1 do
     TMapCharacter(items[a]).render;
 end;
 
 procedure TMapCharacterList.clear;
 var
   obj: TObject;
 begin
 
   {Этот код освобождает все ресурсы, присутствующие в списке}
   if self.count > 0 then
   begin
     repeat
       obj := self.items[0];
       obj.free;
       self.remove(self.items[0]);
     until self.count = 0;
   end;
 end;
 
 destructor TMapCharacterList.Destroy;
 var
   a: Integer;
 begin
 
   if count > 0 then
     for a := 0 to count - 1 do
       TObject(items[a]).free;
   inherited destroy;
 end;
 
 procedure TMapCharacterList.loadfromfile(const filename: string);
 var
 
   i: Integer;
   Reader: Treader;
   Stream: TFileStream;
   obj: TMapCharacter;
 begin
   stream := TFileStream.create(filename, fmOpenRead);
   try
     reader := TReader.create(stream, $FF);
     try
       with reader do
       begin
         try
           ReadSignature;
           if ReadInteger <> $6667 then
             raise EReadError.Create('Не список сиволов.');
         except
           raise EReadError.Create('Неверный формат файла.');
         end;
         ReadListBegin;
         while not EndofList do
         begin
           obj := TMapCharacter.create(FMap);
           try
             obj.ReadData(reader);
           except
             obj.free;
             raise EReadError.Create('Ошибка в файле списка символов.');
           end;
           self.add(obj);
         end;
         ReadListEnd;
       end;
     finally
       reader.free;
     end;
   finally
     stream.free;
   end;
 end;
 
 procedure TMapCharacterList.savetofile(const filename: string);
 var
 
   Stream: TFileStream;
   Writer: TWriter;
   i: Integer;
   obj: TMapCharacter;
 begin
   stream := TFileStream.create(filename, fmCreate or fmOpenWrite);
   try
     writer := TWriter.create(stream, $FF);
     try
       with writer do
       begin
         WriteSignature;
         WriteInteger($6667);
         WriteListBegin;
         for i := 0 to self.count - 1 do
           TMapCharacter(self.items[i]).writedata(writer);
         WriteListEnd;
       end;
     finally
       writer.free;
     end;
   finally
     stream.free;
   end;
 end;
 
 procedure TFrameStore.WriteData(Writer: TWriter);
 var
   mstream: TMemoryStream;
   a, size: Longint;
 begin
 
   mstream := TMemoryStream.Create;
   try
     with writer do
     begin
       WriteListBegin;
       WriteInteger(count);
       for a := 0 to count - 1 do
       begin
         TBitmap(items[a]).savetostream(mstream);
         size := mstream.size;
         WriteInteger(size);
         Write(mstream.memory^, size);
         mstream.position := 0;
       end;
       WriteListEnd;
     end;
   finally
     Mstream.free;
   end;
 end;
 
 procedure TFrameStore.ReadData(Reader: TReader);
 var
   mstream: TMemoryStream;
   a, listcount, size: Longint;
   newframe: TBitMap;
 begin
 
   mstream := TMemoryStream.create;
   try
     with reader do
     begin
       ReadListBegin;
       Listcount := ReadInteger;
       for a := 1 to listcount do
       begin
         size := ReadInteger;
         mstream.setsize(size);
         read(mstream.Memory^, size);
         newframe := TBitmap.create;
         newframe.loadfromstream(mstream);
         add(newframe);
       end;
       ReadListEnd;
     end;
   finally
     Mstream.free;
   end;
 end;
 
 procedure TFrameStore.clear;
 var
   Obj: TObject;
 begin
 
   {{Этот код освобождает все ресурсы, присутствующие в списке}
   if self.count > 0 then
   begin
     repeat
       obj := self.items[0];
       obj.free;
       self.remove(self.items[0]);
     until self.count = 0;
   end;
 end;
 
 end.
 




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


 { ****************************************************************** }
 {                                                                    }
 {   VCL component TDTNTMMPlayer                                      }
 {                                                                    }
 {   This was developed by request!!                                  }
 {                                                                    }
 {                                                                    }
 {   Copyright ® 2001 by Jason White  jason@dtnt.co.uk                }
 {                                                                    }
 { ****************************************************************** }
 
 
 unit DTNTMMPlayer;
 
 interface
 
 uses WinTypes, WinProcs, Messages, SysUtils, Classes, Controls,
      Forms, Graphics, Mplayer, mmsystem;
 
 type
   TDTNTMMPlayer = class(TMediaPlayer)
     private
       { Private fields of TDTNTMMPlayer }
         { Pointer to application's OnChangeTempoError handler, if any }
         FOnChangeTempoError : TNotifyEvent;
         { Pointer to application's OnTempoChanged handler, if any }
         FOnTempoChanged : TNotifyEvent;
 
       { Private methods of TDTNTMMPlayer }
         { Method to set variable and property values and create objects }
         procedure AutoInitialize;
         { Method to free any objects created by AutoInitialize }
         procedure AutoDestroy;
 
     protected
       { Protected fields of TDTNTMMPlayer }
 
       { Protected methods of TDTNTMMPlayer }
         { Method to generate OnChangeTempoError event }
         procedure ChangeTempoError(Sender : TObject); virtual;
         { Method to generate OnTempoChanged event }
         procedure TempoChanged(Sender : TObject); virtual;
         procedure Loaded; override;
         procedure Paint; override;
 
     public
       { Public fields and properties of TDTNTMMPlayer }
 
       { Public methods of TDTNTMMPlayer }
         constructor Create(AOwner: TComponent); override;
         destructor Destroy; override;
         { SetsTempo }
         procedure SetTempo( Value : Integer );
 
     published
       { Published properties of TDTNTMMPlayer }
         property OnChangeTempoError : TNotifyEvent read FOnChangeTempoError
           write FOnChangeTempoError;
         { Tempo Changed Event }
         property OnTempoChanged : TNotifyEvent read FOnTempoChanged
           write FOnTempoChanged;
         property OnClick;
         property OnEnter;
         property OnExit;
         property OnNotify;
         property OnPostClick;
         property AutoEnable default True;
         property AutoOpen default False;
         property AutoRewind default True;
         property ColoredButtons
              default [btPlay, btPause, btStop, btNext, btPrev, btStep,
              btBack, btRecord, btEject];
         property DeviceType default dtAutoSelect;
         property EnabledButtons
              default [btPlay, btPause, btStop, btNext, btPrev, btStep,
              btBack, btRecord, btEject];
         property FileName;
         property Shareable default False;
         property Visible default True;
         property VisibleButtons
              default [btPlay, btPause, btStop, btNext, btPrev, btStep,
              btBack, btRecord, btEject];
 
   end;
 
 procedure Register;
 
 implementation
 
 procedure Register;
 begin
      { Register TDTNTMMPlayer with D-TNT as its
        default page on the Delphi component palette }
      RegisterComponents('D-TNT', [TDTNTMMPlayer]);
 end;
 
 { Method to set variable and property values and create objects }
 procedure TDTNTMMPlayer.AutoInitialize;
 begin
      AutoEnable := True;
      AutoOpen := False;
      AutoRewind := True;
      ColoredButtons := [btPlay, btPause, btStop, btNext, btPrev, btStep,
      btBack, btRecord, btEject];
      DeviceType := dtAutoSelect;
      EnabledButtons := [btPlay, btPause, btStop, btNext, btPrev, btStep,
      btBack, btRecord, btEject];
      Shareable := False;
      Visible := True;
      VisibleButtons := [btPlay, btPause, btStop, btNext, btPrev, btStep,
      btBack, btRecord, btEject];
 end; { of AutoInitialize }
 
 { Method to free any objects created by AutoInitialize }
 procedure TDTNTMMPlayer.AutoDestroy;
 begin
      { No objects from AutoInitialize to free }
 end; { of AutoDestroy }
 
 { Method to generate OnChangeTempoError event }
 procedure TDTNTMMPlayer.ChangeTempoError(Sender : TObject);
 begin
      { Has the application assigned a method to the event, whether
        via the Object Inspector or a run-time assignment?  If so,
        execute that method }
      if Assigned(FOnChangeTempoError) then
         FOnChangeTempoError(Sender);
 end;
 
 { Method to generate OnTempoChanged event }
 procedure TDTNTMMPlayer.TempoChanged(Sender : TObject);
 begin
      { Has the application assigned a method to the event, whether
        via the Object Inspector or a run-time assignment?  If so,
        execute that method }
      if Assigned(FOnTempoChanged) then
         FOnTempoChanged(Sender);
 end;
 
 constructor TDTNTMMPlayer.Create(AOwner: TComponent);
 begin
      { Call the Create method of the parent class }
      inherited Create(AOwner);
 
      { AutoInitialize sets the initial values of variables and      }
      { properties; also, it creates objects for properties of       }
      { standard Delphi object types (e.g., TFont, TTimer,           }
      { TPicture) and for any variables marked as objects.           }
      { AutoInitialize method is generated by Component Create.      }
      AutoInitialize;
 
      { Code to perform other tasks when the component is created }
 
 end;
 
 destructor TDTNTMMPlayer.Destroy;
 begin
      { AutoDestroy, which is generated by Component Create, frees any   }
      { objects created by AutoInitialize.                               }
      AutoDestroy;
 
      { Here, free any other dynamic objects that the component methods  }
      { created but have not yet freed.  Also perform any other clean-up }
      { operations needed before the component is destroyed.             }
 
      { Last, free the component by calling the Destroy method of the    }
      { parent class.                                                    }
      inherited Destroy;
 end;
 
 procedure TDTNTMMPlayer.Loaded;
 begin
      inherited Loaded;
 
      { Perform any component setup that depends on the property
        values having been set }
 
 end;
 
 procedure TDTNTMMPlayer.Paint;
 begin
      { Make this component look like its parent component by calling
        its parent's Paint method. }
      inherited Paint;
 
      { To change the appearance of the component, use the methods
        supplied by the component's Canvas property (which is of
        type TCanvas).  For example, }
 
      { Canvas.Rectangle(0, 0, Width, Height); }
 end;
 
 { SetsTempo }
 procedure TDTNTMMPlayer.SetTempo( Value : Integer );
 var
   Flags: LongInt;
   SeqParm: TMCI_Seq_Set_Parms;
 begin
 pause;
 
   if DeviceType = dtSequencer then
   begin
     SeqParm.dwTempo := Value;
     Flags := MCI_SEQ_SET_TEMPO;
     mciSendCommand(DeviceID, MCI_SET, Flags, Longint(@SeqParm));
     TempoChanged(self);
   end
   else
     ChangeTempoError(self);
 
 resume;
 end;
 
 end.
 




Обмен данными между TMemoField и TMemo


 procedure TMemoToTMemoField;
 begin
   TMemoField.Assign(TMemo.Lines);
 end;
 
 procedure TMemoFieldToTMemo;
 var
   aBlobStream: TBlobStream;
 begin
   aBlobStream := TBlobStream.Create(TMemoField, bmRead);
   TMemo.Lines.LoadFromStream(aBlobStream);
   aBlobStream.Free;
 end;
 




Различия TMemoField

Во-первых, если аргумент size у GetMem равен нулю, GetMem устанавливает указатель в nil (не отбрасывайте такой способ, но разумней самому установить его в nil). Также в отладчике вы могли бы проверять значение DataSize (или getTextLen) перед самим вызовом . (Проигнорируйте следующий параграф, если Table1Notes не Memo.)

Во-вторых, если Table1Notes - Memo-поле, вы, вероятно, захотите использовать Table1Notes.getTextLen, не DataSize, поскольку DataSize возвращает размер сегмента буфера записи (0-254), тогда как getTextLen возвратит вам реальный размер Memo. (Для строкового поля DataSize работать будет, но очень странно, поскольку возвращает ноль.) Также вы можете воспользоваться getTextBuf вместо getData, не знаю точно почему, но мои многочисленные экспериметны показали, что getTextBuf работает правильно и устойчиво, а get Data нет.

Поскольку "wordwrapping" (перенос слов) доступен в вашем приложении, вы можете заменить символы #10 (перевод строки) и #13 (возврат каретки) на пробелы, например так:


 cursor: pchar;
 ...
 cursor := ваш буфер;
 while cursor^ <> #0 do
   if (cursor^ = #13) or (cursor^ = #10) then
     cursor^ := ' ';
 

Данный способ прост, поскольку нам нет нужды перемещать текст из переменной в переменную, хотя и не без недостатка, поскольку в конце каждой строки мы получаем два пробела, что может неправильно интерпретироваться при переносе строк. В качестве альтернати вы, вместо пробела вы можете применить другой служебный символ, который ваш текстовый процессор воспримет в качестве прерывания строки, или проигнорирует его (например, символ #8). Если вам нужно просто избавиться от символов перевода строки, воспользуйте сь двумя курсорами как показано ниже (извините, не тестировал):


 out, in: pchar;
 ...
 out := ваш буфер;
 in := out;
 while in^ <> #0 do
 begin
   if (in^ <> #10) and (in^ <> #13) then
   begin
     out^ := in^;
     inc (out);
   end;
   inc (in);
 end;
 out^ := #0;
 

Если вместо этого вы хотите заменить каждую пару CR-LF или отдельный CR или LF единичным пробелом, попробуйте это:


 out, inn: PChar;
 ...
 out := ваш буфер;
 inn := out;
 while in^ <> #0 do
 begin
   if (in^ = #10) then
   begin
   end
   else
   if (in^ = #13) then
   begin
     if (in+1)^
 

Если вместо этого вы хотите заменить каждую пару CR-LF или отдельный CR или LF единичным пробелом, попробуйте это:


 out, inn: PChar;
 
 out := buf;
 inn := out;
 while inn^ <> #0 do begin
 if (inn^ = #10) or ((inn^ = #13) and ((inn+1)^ <> #10)) then begin
 out^ := ' ';
 Inc(out);
 end
 else if (inn^ = #13) then
 { только CR, игнорируем }
 else begin
 out^ := inn^;
 Inc(out);
 end;
 Inc(inn);
 end;
 out^ := #0;
 { буфер теперь закрыт }
 
 

Непроверенное: эффект уменьшения размера (путем установки терминатора #0) этого PChar позволит уменьшить время компиляции массивов и буферов GetMem, что же будет при использовании StrAlloc/StrDispose?

Вот конечный код после учета всех мелочей! Например, нам, в конечном счете, нужно сообщить указателю о необходимости возвратиться к началу своей новой строки.


 procedure TForm1.RemoveSpaces(var InBuf: PChar; Size: Word);
 var
 
 Input,
 OutPut,
 Orig: PChar;
 begin
 
 GetMem(Output, Size);
 input := Inbuf;
 Orig := Output;
 while input^ <> #0 do
 begin
 if (input^ <> #10) and (input^ <> #13) then
 begin
 output^ := input^;
 inc (output);
 end;
 inc (input);
 end;
 Output^ := #0;
 Output := Orig;
 InBuf := Output;
 end;
 
 

Я все еще немало удивлен тому как работает GetData! Я все еще не хочу использовать TMemo! Если кто-то может решить эту проблему, я буду очень рад! Пока же я готовлю для вас материал, включающий новые процедуры печати! Наведем порядок в беспорядке! Я уже и мею реализацию вывода текста с любым шрифтом и в любой позиции, выраженной в дюймах, и это только начало! Но что я думаю действительно классно вышло, так это диманическая сетка! Вы можете создавать сетку с любым количеством строк и колонок. Назначьте текс т и ячейку, установите горизонтальное и вертикальное выравнивание, выберите стиль границы для каждой ячейки и изучите множество других способов манипулирования и печати сетки!




Загрузка TMemoField в Memo


 Procedure TMemoToTMemoField;
 begin
   TMemoField.Assign( TMemo.Lines );
 end;
 
 Procedure TMemoFieldToTMemo;
 VAR
   aBlobStream : TBlobStream;
 begin
   aBlobStream := TBlobStream.Create(TMemoField, bmRead);
   TMemo.Lines.LoadFromStream( aBlobStream );
   aBlobStream.Free;
 end;
 




TMemoryStream

Думайте о потоке памяти как о расположенном в памяти файле. Команды для работы с потоком очень похожи на команды для работы с файлами. (В действительности, это ближе к команде blockwrite.)

Вот "медленный" путь записи строки в поток:


 for i := 1 to Length(s) do
   memstream.Write(s[i], 1);
 

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


 memstream.Write(s[1], Length(s));
 

Две строчки делают то же самое, они добавляют символы в поток. Если вы не делали никаких перемещений внутреннего курсора потока (seek), символы просто добавляются в конец.

Теперь, для соблюдения перевода каретки, вы должны добавлять эти спецсимволы сами:


 memstream.Write(#13, 1);
 memstream.Write(#10, 1);
 

Или вы можете использовать более изощренный метод:


 procedure StreamWriteStr(var ms: TMemoryStream; s: string);
 begin
   ms.Write(s[1], Length(s));
 end;
 
 procedure StreamWriteLnStr(var ms: TMemoryStream; s: string);
 begin
   StreamWriteStr(ms, s + #13#10);
 end;
 

Также, вы можете создать собственный класс-потомок TMemoryStream, с методом записи строк.




Фильтровать все ссылки в TMemo

Сын к папе-интернетчику подходит:
- Папа, а адрес пишется с одной "с", или с двумя?
- С тремя w, сынок.


 // For this tip you need Memo1, ListBox1, Label1, Button1.
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   i, p: Integer;
   s: string;
 begin
   ListBox1.Clear;
   for i := 0 to Memo1.Lines.Count - 1 do
   begin
     if Pos('http://', Memo1.Lines.Strings[i]) > 0 then
     begin
       s := '';
       {If the current line contains a "http://", read on until a space is found
 
        Die aktuelle Zeile wird nach der Zeichenfolge "http://" durchsucht
        und bei Erfolg ab der gefundenen Position ausgelesen, bis ein
        Leerzeichen auftritt...}
 
       for p := Pos('http://', Memo1.Lines.Strings[i]) to
         Length(Memo1.Lines.Strings[i]) do
         if Memo1.Lines.Strings[i][p] <> ' ' then
           s := s + Memo1.Lines.Strings[i][p]
       else
         break;
 
        {Remove some characters if address doesn't end with a space
 
        Falls die gefundene Adresse nicht mit einem Leerzeichen abschlie?t,
        werden hier noch anhangende Textzeichen entfernt...}
 
       while Pos(s[Length(s)], '..;!")]}?''>') > 0 do
         Delete(s, Length(s), 1);
       // Add the Address to the list... 
       //Gefundene Adresse in die Liste aufnehmen... 
       ListBox1.Items.Add(s);
     end;
   end;
 
   // Show the number of Addresses in Label1 
   // Die Zahl der gefundenen Adressen in Label1 anzeigen... 
 
   if ListBox1.Items.Count > 0 then
     label1.Caption := IntToStr(ListBox1.Items.Count) +
       ' Adresse(n) gefunden.'
   else
     label1.Caption := 'Keine Adresse gefunden.';
 end;
 




TMetaFile - ошибка при работе с памятью

Компьютер - это устройство для упорядочивания, ускорения и автоматизации человеческих ошибок.

Для создания в памяти метафайла, я пытаюсь использовать TMetafile. Чтобы я ни делал, это не работает как надо. Я получаю метафайл или неверного размера, или без возможности масштабирования.

Я долго экспериментировал и пришел к выводу, что все эти ошибки возникают в случае, когда map mode (режим карты) использует не mm_Text. Я трассировал ошибку в TMetafile.SaveToClipboardFormat. Программа неверно использует значение по умолчанию TMetafileImage.FInch = 0. Я думаю что TMetafileImage должен иметь значение по умолчанию FInch = Screen.PixelsPerInch или программа, которая сохраняет его в буфере обмена, должна правильно использовать FInch = 0 (т.е. сделайте значение mm_Text).




Компонент TMinMax

Автор: Robert Wittig

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


 {***************************************************************************** }
 {                                 UMINMAX.PAS }
 {                                      Автор }
 {                                Robert Wittig }
 {                                  76401,242 }
 
 {  Данный модуль обеспечивает вас интерфейсом для управления сообщением WM_GETMINMAXINFO }
 {  на основе компонента . C помощью этого компонента вы легко можете управлять }
 {  минимальным и максимальным размером окна. Вы можете также управлять размером и }
 {  положением максимально раскрытого окна. }
 
 {  Данный модуль свободен в использовании. Вы можете без ограничений использовать его }
 {  в некоммерческих приложениях. Вы можете использовать его в коммерческих приложениях, }
 {  если данный код занимает менее 20% от всего кода приложения. Вы можете свободно }
 {  копировать и распространять данный модуль с условием сохранения (по возможности) }
 {  данной информации. }
 
 {  Пожалуйста посылайте свои коментарии/предложения автору непосредственно в форум }
 {  или по e-mail по адресу 76401,242. Автор не дает никаких гарантий по работе }
 {  данного модуля. }
 
 {  История модуля }
 {  ------------ }
 {  03-05-96  Автор Robert Wittig (CompuServe ID 74601,242) }
 
 {***************************************************************************** }
 unit uMinMax;
 
 interface
 uses Classes, Controls, Forms, Messages, SysUtils, WinProcs, WinTypes;
 
 type
   TMinMax = class(TComponent)
   private
     OldWndProc: Pointer;
     FInstance: Pointer;
 
     MinMaxInfo: TMinMaxInfo;
     FActive: Boolean;
   protected
     procedure Notification(aComponent: TComponent; Operation: TOperation);
       override;
 
     procedure ResetSubclass; virtual;
     procedure Subclass; virtual;
 
     procedure InitMinMaxInfo; virtual;
     procedure MinMaxWndProc(var Message: TMessage); virtual;
 
     function GetMinWidth: Integer; virtual;
     function GetMinHeight: Integer; virtual;
     function GetMaxWidth: Integer; virtual;
     function GetMaxHeight: Integer; virtual;
 
     function GetMaximizedX: Integer; virtual;
     function GetMaximizedY: Integer; virtual;
     function GetMaximizedWidth: Integer; virtual;
     function GetMaximizedHeight: Integer; virtual;
 
     function GetReset: Boolean; virtual;
 
     procedure SetActive(Value: Boolean); virtual;
 
     procedure SetMinWidth(Value: Integer); virtual;
     procedure SetMinHeight(Value: Integer); virtual;
     procedure SetMaxWidthWM_GETMINMAXINFO(Value: Integer); virtual;
     procedure SetMaxHeight(Value: Integer); virtual;
 
     procedure SetMaximizedX(Value: Integer); virtual;
     procedure SetMaximizedY(Value: Integer); virtual;
     procedure SetMaximizedWidth(Value: Integer); virtual;
     procedure SetMaximizedHeight(Value: Integer); virtual;
 
     procedure SetReset(Value: Boolean); virtual;
 
     procedure SetNewSize; virtual;
   public
     destructor Destroy; override;
   published
     property Active: Boolean read FActive write SetActive;
 
     property MinWidth: Integer read GetMinWidth write SetMinWidth;
     property MinHeight: Integer read GetMinHeight write SetMinHeight;
     property MaxWidth: Integer read GetMaxWidth write SetMaxWidth;
     property MaxHeight: Integer read GetMaxHeight write SetMaxHeight;
 
     property MaximizedX: Integer read GetMaximizedX write SetMaximizedX;
     property MaximizedY: Integer read GetMaximizedY write SetMaximizedY;
     property MaximizedWidth: Integer read GetMaximizedWidth write
       SetMaximizedWidth;
 
     property MaximizedHeight: Integer read GetMaximizedHeight write
       SetMaximizedHeight;
 
     {**************************** RCW 03-05-96 ************************}
     { Reset является псевдо-свойством. Если значение равно True, TMinMax сбрасывает }
     { свойства Min/Max и устанавливает значения по умолчанию. }
     {**************************** RCW 03-05-96 ************************}
     property Reset: Boolean read GetReset write SetReset;
   end;
 
   {********************************** RCW 03-05-96 ******************************}
   {  Использование: Общая информация относительно WM_GETMINMAXINFO содержится }
   {             в статьях WM_GETMINMAXINFO и TMINMAXINFO в файле справке }
   {             по функциям API. Также, имейте в виду следующее: }
   {               1) При перемещении границ окна минимальные/максимальные }
   {                   размеры окна определяются свойствами MinWidth, MaxWidth,}
   {                   MinHeight и MaxHeight. }
 
   {               2) При максимизации окна максимальная высота и ширина }
   {                   окна определяются соответственно Min(MaxHeight, }
   {                   MaximizedHeight) и Min(MaxWidth,MaximizedWidth). Это }
   {                   функция Windows и не зависит от работы компонента. }
   {                   ( Примечание: возможно иметь окно, которое }
   {                            имеет рамку большего размера чем максимальный }
   {                            размер окна. )               }
 
   {               3) Будьте осторожными при установке MaximizedX и MaximizedY. }
   {                   Примечание: если вы установили это слишком маленьким }
   {                   или слишком большим, ни кнопка, ни заголовок (для двойного }
   {                   щелчка) видимыми не будут. Следовательно, вы не можете }
   {                   восстановить окно до нормального состояния через нормальный }
   {                   интерфейс Windows. }
 
   {********************************** RCW 03-05-96 ******************************}
 
 procedure Register;
 
 implementation
 
 procedure Register;
 begin
   RegisterComponents('Custom', [TMinMax]);
 end;
 
 destructor TMinMax.Destroy;
 begin
   if FInstance <> nil then
     FreeObjectInstance(FInstance);
 
   inherited Destroy;
 end;
 
 procedure TMinMax.Notification(aComponent: TComponent; Operation: TOperation);
 begin
   if aComponent = Self then
     if Operation = opInsert then
       Subclass
     else if Operation = opRemove then
       ResetSubclass;
 
   inherited Notification(aComponent, Operation);
 end;
 
 procedure TMinMax.ResetSubclass;
 begin
   if (FInstance <> nil) and
     (Owner <> nil) then
     if IsWindow(TWinControl(Owner).Handle) then
       SetWindowLong(TWinControl(Owner).Handle, GWL_WNDPROC,
         LongInt(OldWndProc));
 
 end;
 
 procedure TMinMax.Subclass;
 begin
   if Owner is TWinControl then
     with TWinControl(Owner) do
     begin
       if FInstance = nil then
         FInstance := MakeObjectInstance(MinMaxWndProc);
       OldWndProc := Pointer(GetWindowLong(Handle, GWL_WNDPROC));
       SetWindowLong(Handle, GWL_WNDPROC, LongInt(FInstance));
       InitMinMaxInfo;
     end;
 end;
 
 procedure TMinMax.InitMinMaxInfo;
 begin
   with MinMaxInfo do
   begin
     if Owner is TForm then
       with ptMaxPosition do
         case TForm(Owner).BorderStyle of
           bsSingle:
             begin
               X := -GetSystemMetrics(SM_CXBORDER);
               Y := -GetSystemMetrics(SM_CYBORDER);
             end;
           bsSizeable:
             begin
               X := -GetSystemMetrics(SM_CXFRAME);
               Y := -GetSystemMetrics(SM_CYFRAME);
             end;
         end;
 
     with ptMaxSize do
     begin
       X := Screen.Width - 2 * ptMaxPosition.X;
       Y := Screen.Height - 2 * ptMaxPosition.Y;
     end;
 
     ptMaxTrackSize := ptMaxSize;
   end;
 end;
 
 procedure TMinMax.MinMaxWndProc(var Message: TMessage);
 begin
   Message.Result := CallWindowProc(TFarProc(OldWndProc),
     TWinControl(Owner).Handle,
     Message.Msg, Message.wParam, Message.lParam);
 
   if FActive and (Message.Msg = WM_GETMINMAXINFO) then
     PMinMaxInfo(Message.lParam)^ := MinMaxInfo;
 end;
 
 function TMinMax.GetMinWidth: Integer;
 begin
   Result := MinMaxInfo.ptMinTrackSize.X;
 end;
 
 function TMinMax.GetMinHeight: Integer;
 begin
   Result := MinMaxInfo.ptMinTrackSize.Y;
 end;
 
 function TMinMax.GetMaxWidth: Integer;
 begin
   Result := MinMaxInfo.ptMaxTrackSize.X;
 end;
 
 function TMinMax.GetMaxHeight: Integer;
 begin
   Result := MinMaxInfo.ptMaxTrackSize.Y;
 end;
 
 function TMinMax.GetMaximizedX: Integer;
 begin
   Result := MinMaxInfo.ptMaxPosition.X;
 end;
 
 function TMinMax.GetMaximizedY: Integer;
 begin
   Result := MinMaxInfo.ptMaxPosition.Y;
 end;
 
 function TMinMax.GetMaximizedWidth: Integer;
 begin
   Result := MinMaxInfo.ptMaxSize.X;
 end;
 
 function TMinMax.GetMaximizedHeight: Integer;
 begin
   Result := MinMaxInfo.ptMaxSize.Y;
 end;
 
 function TMinMax.GetReset: Boolean;
 begin
   Result := False;
 end;
 
 procedure TMinMax.SetActive(Value: Boolean);
 begin
   if Value <> FActive then
   begin
     FActive := Value;
     SetNewSize;
   end;
 end;
 
 procedure TMinMax.SetMinWidth(Value: Integer);
 begin
   if Value < 0 then
     Value := 0;
 
   if Value <> MinMaxInfo.ptMinTrackSize.X then
   begin
     MinMaxInfo.ptMinTrackSize.X := Value;
     SetNewSize;
   end;
 end;
 
 procedure TMinMax.SetMinHeight(Value: Integer);
 begin
   if Value < 0 then
     Value := 0;
 
   if Value <> MinMaxInfo.ptMinTrackSize.Y then
   begin
     MinMaxInfo.ptMinTrackSize.Y := Value;
     SetNewSize;
   end;
 end;
 
 procedure TMinMax.SetMaxWidth(Value: Integer);
 begin
   if Value < MinMaxInfo.ptMinTrackSize.X then
     Value := MinMaxInfo.ptMinTrackSize.X;
 
   if Value <> MinMaxInfo.ptMaxTrackSize.X then
   begin
     MinMaxInfo.ptMaxTrackSize.X := Value;
     SetNewSize;
   end;
 end;
 
 procedure TMinMax.SetMaxHeight(Value: Integer);
 begin
   if Value < MinMaxInfo.ptMinTrackSize.Y then
     Value := MinMaxInfo.ptMinTrackSize.Y;
 
   if Value <> MinMaxInfo.ptMaxTrackSize.Y then
   begin
     MinMaxInfo.ptMaxTrackSize.Y := Value;
     SetNewSize;
   end;
 end;
 
 procedure TMinMax.SetMaximizedX(Value: Integer);
 begin
   MinMaxInfo.ptMaxPosition.X := Value;
 end;
 
 procedure TMinMax.SetMaximizedY(Value: Integer);
 begin
   MinMaxInfo.ptMaxPosition.Y := Value;
 end;
 
 procedure TMinMax.SetMaximizedWidth(Value: Integer);
 begin
   MinMaxInfo.ptMaxSize.X := Value;
 end;
 
 procedure TMinMax.SetMaximizedHeight(Value: Integer);
 begin
   MinMaxInfo.ptMaxSize.Y := Value;
 end;
 
 procedure TMinMax.SetReset(Value: Boolean);
 begin
   if Value then
     InitMinMaxInfo;
 end;
 
 procedure TMinMax.SetNewSize;
 begin
   if not FActive then
     Exit;
 
   {**************************** RCW 03-05-96 ******************************}
   { Если размер окна превышает допустимые пределы, производим необходимую коррекцию. }
   {****************************** RCW 03-05-96 ****************************}
   if FInstance = nil then
     raise Exception.Create('Не могу управлять WM_GETMINMAXINFO, поскольку
       Owner не TWinControl' )
 
   else
     with TWinControl(Owner), MinMaxInfo do
     begin
       if (ptMinTrackSize.X <> 0) or
         (ptMaxTrackSize.X <> 0) then
         if Width < ptMinTrackSize.X then
           Width := ptMinTrackSize.X
         else if Width > ptMaxTrackSize.X then
           Width := ptMaxTrackSize.X;
 
       if (ptMinTrackSize.Y <> 0) or
         (ptMaxTrackSize.Y <> 0) then
         if Height < ptMinTrackSize.Y then
           Height := ptMinTrackSize.Y
         else if Height > ptMaxTrackSize.Y then
           Height := ptMaxTrackSize.Y;
     end;
 end;
 
 end.
 




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

Автор: Садыков Алексей Николаевич

Запускайте Delphi. Итак, наша программа будет представлять из себя форму с двумя edit'ами и кнопкой. Добавьте их на форму.

При нажатии на кнопку будут осуществляться некоторые долгие вычисления. Если бы мы не использовали потоки, то, пока эти вычисления не закончатся, делать мы ничего бы не смогли. Надо было бы ждать. Но, так как потоки у нас будут, то во время долгих вычислений можно будет что-нибудь вводить во второй edit (он, собственно, только для этого и существует). В первый же edit наш поток будет выводить некоторые промежуточные результаты своей работы.

Добавьте в программу еще один модуль (меню File, New, Unit).

Внесите в окно кода нового модуля следующий код:


 unit Unit2;
 
 interface
 
 uses
   Classes;
 
 type
   TMyThread = class(TThread) //Новый класс
   private
     answer: Integer;
   protected
     procedure ShowResult;
     procedure Execute; override;
   end;
 
 implementation
 
 uses
   SysUtils, Unit1;
 
 //Процедура для вывода информации из потока
 procedure TMyThread.ShowResult;
 begin
   Form1.Edit1.Text := IntToStr(answer);
 end;
 
 //Длинная процедура
 procedure TMyThread.Execute;
 var
   i: Integer;
 begin
   for i := 1 to 10000 do
   begin
     answer := answer + 1;
     Synchronize(ShowResult);
   end;
 end;
 
 end.
 

Немного комментария по коду. В нашем модуле мы вводим новый класс TMyThread как «потомок» TThread. В экземпляре нашего класса и будет выполнятся отдельный поток программы. В классе есть процедура ShowResult для вывода информации из работающего потока в основной поток (форму) нашей программы. Кроме того, в классе есть наша версия метода Execute из родительского класса TThread. Обратите внимание, что в нашей реализации Execute мы пишем

 Synchronize(ShowResult);
 

Тем самым наш поток что-то отправляет в основной поток программы (в данном случае, значение переменной answer). Делаем мы это посредством вызова Synchronize, в котором в качестве параметра указываем имя нужной процедуры.

Теперь переходим к нашему основному модулю Unit1. Во-первых, добавьте в секцию uses ссылку на Unit2:

 uses
   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, Unit2;
 

Во-вторых, напишите обработчик для нажатия кнопки:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   MyThread: TMyThread;
 begin
   MyThread := TMyThread.Create(False);
 end;
 

Тут мы создаем второй поток для нашего приложения. Параметр False означает, что метод Execute для нашего потока вызовется немедленно.

Запускайте программу. Нажимайте на кнопку. В первом edit'е замелькают промежуточные результаты работы второго потока. Во время его работы вы можете вводить информацию во второй edit — т.е. работа одного потока не мешает работе другого.




Компонент TNMDayTime


Пользователь технической поддержке:
- Да что же это такое?!!! Всякий раз, когда я вам звоню, мой интернет отключается!!!

Этот компонент предназначен для получения даты и времени от серверов даты и времени в интернет и интранет в соответствии со стандартом RFC 867, называемым "Протокол времени суток".

Если у вас в "подчинении" один домашний компьютер, то время на нём можно периодически подводить по своим часам - здесь точность не требуется, но если вы администратор малой или большой сети, если у вас есть многопользовательская программа, то для синхронизации времени на машинах нужно использовать некий механизм. Например, эту возможность, предоставляемую интернет.

В интернете используются 4 временных протокола. Протокол, используемый в TNMDayTime, достаточно простой и даёт время с погрешностью в 1секунду. Этому протоколу требуется наличие 32-битного стека протоколов TCP/IP (библиотеки WSOCK32.DLL), поставляемой с операционными системами Windows 95/98/NT. За протоколом даты/времени закреплён порт 13.

Перед тем как использовать этот компонент, вы должны знать имя или IP-адрес соответствующего сервера Интернет и присвоить это значение свойству Host, в которое помещается имя сервера или разделённый точками IP-адрес. После того как вы сделали это и установили соединение, вам остаётся считать полученное значение из свойства DayTimeStr

Пример:


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   NMDayTime1.ReportLevel:=Status_Basic;
   NMDayTime1.TimeOut:=30000;
   NMDayTime1.Host:=Edit1.Text;
   NMDayTime1.Port:=StrToInt(Edit2.Text);
   Label3.Caption:=NMDayTime1.DayTimeStr;
 end;
 




Компонент TNMEcho


Гуляя по лесу, программист набрел на пещеру.
- А! - крикнул он.
- А!... А!... А!... - ответило эхо.
- Эхо!- позвал он.
- Echo is ON,- ответило эхо.

Компонент применяется для отсылки текстовых сообщений на эхо-сервер и получения этого сообщения обратно в соответствии со стандартом RFC 862.

Этот компонент обычно применяется для тестирования и настройки сети., поскольку мы можем оценить время ответа сервера, которое помещается в свойство ElapsedTime. Это единственное собственное свойство компонента, остальные наследуются.

Перед отправкой сообщения должно быть установлено соединение с сервером. Для этого нужно задать имя сервера или его адрес в свойстве Host, а в свойстве Port определить соответствующий порт [обычно серверы эхо слушают 7-ой порт]. После этого нужно вызвать метод Connect. Для отправки сообщения нужно использовать метод Echo. В случае успеха вы должны получить от сервера ту строку, которую вы передали в качестве параметра методу Echo. После этого для завершения связи вы должны вызвать метод Disconnect. Все методы, кроме Echo, компонент наследует.

Пример:


 // Подключиться
 NMEcho1.Host:=Edit1.Text;
 NMEcho1.Connect;
 
 // Отключиться
 NMEcho1.Disconnect;
 
 // Отправить
 Memo1.Lines.Add(NMEcho1.Echo(Edit2.Text) + 'время [' +
 FloatToStr(NMEcho1.ElapsedTime) + ']');
 
 // Прекратить
 NMEcho1.Abort;
 




Компонент TNMFinger


Коннектится человек к серваку на 28800.
Login: ....
Passwrd: ******
А серв ему выдает:
"Ваш пароль наполовину правильный. Connect 14400".

Данный компонент применяется для получения информации о пользователе от сервера Finger, используя протокол, описанный в стандарте RFC 1288.

Для того, чтобы получить информацию о пользователе, помещаемую в свойство FingerStr, вам нужно в свойстве Host указать имя сервера Finger. Обычно свойство Port не нужно определять, поскольку большинство рассматриваемых серверов используют 79-ый порт. И, конечно, вам нужно указать интересующее вас имя пользователя в свойстве User. Иногда эта служба используется для получения некоторой информации, например, о спорте, погоде. Обратившись по такому адресу, вы найдёте в свойстве FingerStr рассылаемую информацию.

Пример:

По нажатию на кнопку напишите такой код:


 NMFinger1.User:=Edit2.Text;
 NMFinger1.Host:=Edit1.Text;
 Memo1.Text:=NMFinger1.FingerStr;
 

Ну вот, казалось бы и всё, но чтобы программа уведомляла вас о каждом событии нужно вынести StatusBar, в свойстве Panels создать 1 панель. И описать все события компонента TNMFinger примерно так:


 procedure TForm1.NMFinger1Connect(Sender: TObject);
 begin
   StatusBar1.Panels[0].Text:='Подключились';
 end;
 
 procedure TForm1.NMFinger1ConnectionFailed(Sender: TObject);
 begin
   StatusBar1.Panels[0].Text:='Невозможно установить соединение';
 end;
 
 procedure TForm1.NMFinger1Disconnect(Sender: TObject);
 begin
   StatusBar1.Panels[0].Text:='Отсоединились';
 end;
 
 procedure TForm1.NMFinger1HostResolved(Sender: TComponent);
 begin
   StatusBar1.Panels[0].Text:='Host найден';
 end;
 
 procedure TForm1.NMFinger1InvalidHost(var Handled: Boolean);
 begin
   StatusBar1.Panels[0].Text:='Host указан неверно';
 end;
 
 procedure TForm1.NMFinger1Status(Sender: TComponent; Status: string);
 begin
   StatusBar1.Panels[0].Text:=Status;
 end;
 




Компонент TNMFTP

Сидит Дрим перед компом, занимается аутотренингом:
- Я не войду в Интернет, я не войду в Интернет, я не войду в Интернет...
Срывается, стучит что-то на клавиатуре. На дисплее появляется: "Delphi World". Дрим:
- Это не я... Это не я...

Компонент TNMFTP предназначен для обмена файлами между сервером FTP и клиентской машиной по протоколу FTP. FTP является одной из старейших и заслуженных служб интернета.

Она существовала тогда, когда ещё не было WWW и предоставляла удобный по тем временам сервис для обмена файлами и организации различных архивов документов и программ. Сейчас получить доступ к серверу FTP можно непосредственно из браузера WWW, так что клиентские программы для работы с сервером FTP уже не так актуальны. Мы рассмотрим пример с этим компонентом, поскольку такая программа может потребоваться для работы с корпоративным FTP-сервером, где доступ разграничен и требуется пройти идентификацию для доступа к файловому архиву.

Перед использованием компонента TNMFTP для обмена файлами с удалённым компьютером вам нужно подключиться к серверу FTP. Для этого вы должны определить свойства Host и Port значениями, соответствующими нужному серверу FTP. Затем задайте в свойствах UserID и Password необходимые имя пользователя и пароль. Многие публичные серверы FTP принимают значение Anonymous в качестве имени пользователя и в качестве пароля ваш e-mail или строку, напоминающую e-mail, например, user@mycomputer.com, главное, чтобы в этой строке присутствовал символ собачки "@". Таких анонимных серверов в интернет довольно много и используются они как публичные архивы программ и документов. После определения свойств UserID и Password вызывайте метод Connect для установки связи с сервером.

Компонент TNMFTP имеет следующие основные свойства:

  • CurrentDir
  • FTPDirectoryList
  • OnListItem
  • ParseList
  • Password
  • UserID
  • Vendor

Специфических методов у этого компонента немного больше:

  • Allocate
  • ChangeDir
  • Delete
  • DoCommand
  • Download
  • DownloadRestore
  • List
  • MakeDirectory
  • Mode
  • Nlist
  • Reinitialize
  • RemoveDir
  • Rename
  • Upload
  • UploadAppend
  • UploadRestore
  • UploadUnique

Остальные свойства и методы этого компонента наследуются. Ниже мы разберём основные возможности этого компонента и разберём перечисленные свойства и методы.

Если метод компонента TNMFTP завершается успешно, то генерируется событие OnSuccess, в противном случае возникает событие OnFailture. В обоих случаях через параметр Trans_Type обработчиков этих событий передаётся имя команды типа TCmdType. Этот параметр может принимать следующие значения:

  • cmdChangeDir
  • cmdMakeDir
  • cmdDelete
  • cmdRemoveDir
  • cmdList
  • cmdRename
  • cmdUpRestore
  • cmdDownRestore
  • cmdDownload
  • cmdUpload
  • cmdAppend
  • cmdReInit
  • cmdAllocate
  • cmdNlist
  • cmdDoCommand
  • cmdCurrentDir

Думаю, имя метода, к которому относится данное значение определить не трудно

Определение содержимого каталога на удалённом компьютере:

Если вы уже подключены к серверу, вы можете получить список файлов файлов и каталогов текущего каталога при помощи метода List и обработчика события OnListItem, которое вызывается для каждого элемента списка. Вы можете обрабатывать каждый элемент каталога в обработчике этого события. или включить режим разбора строк элементов каталога, установив свойство ParseList в true. В последнем случае компонент разберёт полученные данные и поместит имена, размеры файлов атрибуты, время последнего изменения в составное свойство FTPDirectoryList. Каждый элемент этого свойства представляет собой объект типа TStringList. Для указанных элементов списка содержимого каталога эти объекты имеют имена Name[i], Size[i], ModifDate[i], Attribute[i]. Если метод List завершается успешно, то происходит событие OnSuccess, в противном случае генерируется событие OnFailure. Метод NList представляет собой сокращённый вариант команды List и используется для получения только имён файлов и каталогов.

Изменение текущего каталога на удалённом компьютере:

Вы можете перейти на другой каталог сервера FTP, вызывая метод ChangeDir с именем нужного вам каталога, которое передаётся через параметр DirName. В DirName можно указывать полный путь или имя каталога относительно текущего каталога.

Загрузка файлов на удалённый компьютер:

Для загрузки файлов в текущий каталог на удалённом компьютере используем метод Upload. Метод использует 2 параметра: имя файла на локальном компьютере и имя, под которым он будет сохраняться на удалённом [LocalFile, RemoteFile]. Нужно заметить, что для выполнения данной операции у вас должны быть соответствующие права на удалённом компьютере. Обычно серверы FTP предоставляют такие права в каталоге incoming. В том случае, если на сервере уже есть файл с тем же именем, с которым вы хотите создать новый, - этот файл будет перезаписан. Избежать этого эффекта можно, если использовать метод UploadUnique. Единственный параметр LocalFile этого метода определяет имя файла на локальном компьютере и использует его для создаваемого файла на сервере. Если на сервере файл с таким именем уже существует, то передаваемый файл будет создан с уникальным именем. Метод UploadRestore хорош тем, что он позволяет восстановить прерванный в предыдущем сеансе процесс загрузки файла с места, в котором произошёл обрыв. Последний метод из этой серии UploadAppend позволяет дописывать содержимое локального файла в конец файла на сервере, если файл существует. Если на сервере такого файла нет, то файл создаётся заново. Два последних метода имеют 2 параметра LocalFile и RemoteFile.

Загрузка файлов с удалённого компьютера:

Перед загрузкой файлов с удалённого компьютера имеет смысл вызвать метод List и убедиться, что нужный вам файл имеется на удалённом компьютере. После этого можно вызвать метод по имени Download передав ему в качестве параметров имя загружаемого файла и имя файла и каталога на локальном компьютере: параметры RemoteFile и LocalFile. Нужно заметить, что загружать файлы из любого каталога FTP-сервера обычно не разрешается. Вы можете сделать это только из каталогов, открытых для этой операции. Если на вашем компьютере уже имеется файл с таким именем он будет перезаписан. На случай обрыва связи можно использовать метод DownloadRestore, который позволит продолжить загрузку с того места, на котором произошёл обрыв связи.

Создание каталога на удалённом компьютере:

Для выполнения этой операции у вас должны быть соответствующие права. Обычно на FTP-серверах эти права выделяются на каталог incoming. Для создания каталога достаточно вызвать метод MakeDirectory, передав ему в качестве параметра имя того каталога, который вы хотите создать.

Удаление файла или каталога на удалённом компьютере:

Файл удаляется методом Delete, а для удаления каталога применяется метод RemoveDir. Можно задавать имя файла или каталога внутри текущего каталога или указывать полный путь и имя удаляемого объекта.

Мы не упомянули ещё методы Allocate, DoCommand, Mode, Reinitialize и Rename. Первый метод выделяет место на FTP сервере под создаваемый файл. Как правило, этого делать не требуется, но если вам придётся работать с таким сервером, который требует выделения дисковой памяти перед закачкой на него файла, то этот метод может понадобится.

Метод DoCommand позволяет посылать команду FTP-серверу, который должен её выполнить. Имеется в виду команда операционной системы. Этот метод может вам понадобиться, если для выполнения вашей задачи методов компонента TNMFTP окажется недостаточно, либо если вам попадётся сервер с нестандартными командами.

Метод Rename используется для переименования файла в текущем каталоге на удалённой системе. Первый параметр FileName задаёт имя файла, который нужно переименовать, второй - FileName2 - новое имя для заданного файла.

Метод Mode задаёт режим приёма/передачи файлов. Используются 3 режима. Соответственно параметр TheMode может принимать соответствующие значения:

  • MODE_ASCII - передача текстовых данных
  • MODE_IMAGE - двоичные данные с 8-битовыми байтами
  • MODE_BYTE - двоичные данные с байтами переменной длины

Метод Reinitialize используется для восстановления прерванного соединения. После этого метода требуется зарегистрироваться, ввести имя пользователя и пароль.




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



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



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


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