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

ВИДЕОКУРС ВЗЛОМ
обновлён 2 декабря!


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

БОЛЬШОЙ FAQ ПО DELPHI



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

Всё, что нам нужно, это HRGN и дескриптор (handle) элемента управления. SetWindowRgn имеет три параметра: дескриптор окна, которое будем менять, дескритор региона и булевый (boolean) параметр, который указывает - перерисовывать или нет после изменения. Как только у нас есть дескриптор и регион, то можно вызвать SetWindowRgn(Handle, Region, True) и вуаля!

Заметьте, что Вы не должны освобождать регион при помощи DeleteObject, так как после вызова SetWindowRgn владельцем региона становится операционная система.


 function BitmapToRgn(Image: TBitmap): HRGN;
 var
   TmpRgn: HRGN;
   x, y: integer;
   ConsecutivePixels: integer;
   CurrentPixel: TColor;
   CreatedRgns: integer;
   CurrentColor: TColor;
 begin
   CreatedRgns := 0;
   Result := CreateRectRgn(0, 0, Image.Width, Image.Height);
   inc(CreatedRgns);
 
   if (Image.Width = 0) or (Image.Height = 0) then
     exit;
 
   for y := 0 to Image.Height - 1 do
   begin
     CurrentColor := Image.Canvas.Pixels[0,y];
     ConsecutivePixels := 1;
     for x := 0 to Image.Width - 1 do
     begin
       CurrentPixel := Image.Canvas.Pixels[x, y];
 
       if CurrentColor = CurrentPixel then
         inc(ConsecutivePixels)
       else
       begin
         // Входим в новую зону
         if CurrentColor = clWhite then
         begin
           TmpRgn := CreateRectRgn(x - ConsecutivePixels, y, x, y + 1);
           CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
           inc(CreatedRgns);
           DeleteObject(TmpRgn);
         end;
         CurrentColor := CurrentPixel;
         ConsecutivePixels := 1;
       end;
     end;
 
     if (CurrentColor = clWhite) and (ConsecutivePixels > 0) then
     begin
       TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1);
       CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
       inc(CreatedRgns);
       DeleteObject(TmpRgn);
     end;
   end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   MaskBmp: TBitmap;
 begin
   MaskBmp := TBitmap.Create;
   try
     MaskBmp.LoadFromFile('c:\Мои документы\DW.bmp');
     Height := MaskBmp.Height;
     Width := MaskBmp.Width;
     // ОС владеет регионом, после вызова SetWindowRgn
     SetWindowRgn(Self.Handle, BitmapToRgn(MaskBmp), True);
   finally
     MaskBmp.Free;
   end;
 end;
 




Создание кросс-таблицы

Автор: Michael Lant

Вы можете создать их в DBD как QBE-шки. Пользуясь компонентом TQBE для загрузки одной из библиотек, вы можете непосредственно использовать QBE-шки в вашем Delphi-приложении.

В следующем примере предполагается, что каждый служащий каждый день сообщает оператору о своем месторасположении. Код определяет начало трудовой недели с понедельника плюс еще четыре рабочих дня с показом соответствующей даты. Строки с 1 по 5 в QBE1.QBE (нулевая описательная) в нижеприведенной процедуре заменяются кодом. Результат всего этого в том, что строка (если имеется) для каждого человека отображается в колонке установленного результата и значение 'X' включается если только запись существует. Для создания агрегатной таблицы можно было бы подсчитывать результаты.

Текст в QBE1.QBE :

 CALLIN.DB | StaffNo   | Date    |
           | _join1    | 3/10/95 |
           | _join2    | 3/11/95 |
           | _join3    | 3/12/95 |
           | _join4    | 3/13/95 |
           | _join5    | 3/14/95 |
 
 XTAB.DB   | StaffNo   |Mon       |Tue       |Wed       |Thu       |Fri       |
           | _join1    |changeto X|          |          |          |          |
           | _join2    |          |changeto X|          |          |          |
           | _join3    |          |          |changeto X|          |          |
           | _join4    |          |          |          |changeto X|          |
           | _join5    |          |          |          |          |changeto X|
 
 

 procedure TCallInReport.ButtonSelectClick(Sender: TObject);
 begin
   TableXTab.active := false;
   if EditWeekOf.Text = '' then
   begin
     messageBeep(0);
     messageDlg('Для выбора записи необходима дата.', mtInformation, [mbOK], 0);
     exit;
   end;
 
   Screen.Cursor := crHourGlass;
 
   dtWeekOf := StrToDate(EditWeekOf.Text);
   dtStartDate := dtWeekOf - DayOfWeek(dtWeekOf) + 2;
 
   TableXTab.active := false;
   TableXTab.EmptyTable;
   TableXTab.active := true;
 
   {
   Замените строки 1 - 5 в QBE1.QBE реальными датами
   }
   QBE1.QBE.Strings[1] := '  | _join1  | ' + DateToStr(dtStartDate) + ' | ';
   QBE1.QBE.Strings[2] := '  | _join2  | ' + DateToStr(dtStartDate + 1) + ' | ';
   QBE1.QBE.Strings[3] := '  | _join3  | ' + DateToStr(dtStartDate + 2) + ' | ';
   QBE1.QBE.Strings[4] := '  | _join4  | ' + DateToStr(dtStartDate + 3) + ' | ';
   QBE1.QBE.Strings[5] := '  | _join5  | ' + DateToStr(dtStartDate + 4) + ' | ';
 
   try
     QBE1.active := true;
   except
     on E: EDataBaseError do
     begin
       if E.Message = 'Ошибка создания дескриптора курсора' then
         { Ничего не делайте. Делая TQBE активной, мы пытаемся создать курсор.
           Это вызывает исключительную ситуацию, которую мы должны перехватить.
           Пока я не нашел способа как отделаться от исключения. }
       else
       begin
         Screen.Cursor := crDefault;
         raise;
       end;
     end;
   else
     Screen.Cursor := crDefault;
     raise;
   end;
   TableXTab.refresh;
   Screen.Cursor := crDefault;
   TableXTab.active := true;
 end;
 




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

Данная процедура полезна для создания временных таблиц :


  procedure MakeDataBase;
  begin
    with TTable.Create(nil) do
    begin
      DatabaseName  := 'c:\temp';  (* alias *)
      TableName     := 'test.dbf';
      TableType     := ttDBase;
      with FieldDefs do
      begin
        Add('F_NAME', ftString,20,false);
        Add('L_NAME', ftString,30,false);
      end;
      CreateTable;
      { create a calculated index }
      with IndexDefs do
      begin
        Clear;
        { don't forget ixExpression in calculated indexes! }
        AddIndex('name','Upper(L_NAME)+Upper(F_NAME)',[ixExpression]);
      end;
    end;
  end;
 




Создание DTD для объекта (XML)

- Дорогая, у меня для тебя сюрприз: я открыл новый ужасный вирус и назвал его твоим именем!

За созданием кода для сериализации и десериализации объектов в Delphi логично перейти к рассмотрению вопроса о возможности генерации соответствующего DTD для сохраняемых в XML классов. DTD понадобится нам, если мы захотим провести проверку XML документа на корректность и допустимость с помощью одного из XML анализаторов. Работа с анализатором MSXML рассмотрена в статье Загрузка и анализ документа XML..

Автоматическое создание DTD очень простая задача. У нас все для этого есть. Необходимо рекурсивно пройтись по всем свойствам объекта и сгенерировать модели содержания для каждого тега. При сериализации в XML мы не использовали атрибутов, а значит мы не сможем в DTD установить контроль над содержанием конкретных элементов. Остается только определить модель содержания для XML, т.е. вложенность тегов в друг друга.

Создадим процедуру GenerateDTD(), которая обеспечит запись формируемого DTD для заданного объекта Component в заданный поток Stream. Она создает список DTDList, в котором будут накапливаться атрибуты DTD, после чего передает всю черновую работу процедуре GenerateDTDInternal().


 {
 Процедура генерации DTD для заданного объекта в
 соответсвии с published интерфейсом его класса.
 
 Вход:
   Component - объект
 Выход:
   текст DTD в поток Stream
 }
 procedure GenerateDTD(Component: TObject; Stream: TStream);
 var
   DTDList: TStringList;
 begin
   DTDList := TStringList.Create;
   try
     GenerateDTDInternal(Component, DTDList, Stream, Component.ClassName);
   finally
     DTDList.Free;
   end;
 end;
 

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

Для всех неклассовых типов модель содержания это - (#PCDATA). К примеру, свойство объекта Tag: integer превращается в .

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


 {
 Внутренняя рекурсивная процедура генерации DTD для заданного объекта.
 
 Вход:
   Component - объект
   DTDList - список уже определенных элементов DTD
   для предотвращения повторений.
 Выход:
   текст DTD в поток Stream
 }
 procedure GenerateDTDInternal(Component: TObject; DTDList: TStrings;
   Stream: TStream; const ComponentTagName: string);
 var
   PropInfo: PPropInfo;
   TypeInf, PropTypeInf: PTypeInfo;
   EnumInfo: PTypeInfo;
   TypeData: PTypeData;
   i, j: integer;
   AName, PropName, sPropValue, s, TagContent: string;
   PropList: PPropList;
   NumProps: word;
   PropObject: TObject;
 const
   PCDATA = '#PCDATA';
 
   procedure addElement(const ElementName: string; Data: string);
   var
     s: string;
   begin
     if DTDList.IndexOf(ElementName) <> -1 then
       exit;
     DTDList.Add(ElementName);
     s := 'if Data = '' then
       Data := PCDATA;
     s := s + '(' + Data + ')>'#13#10;
     Stream.write(PChar(s)[0], length(s));
   end;
 
 begin
   { Playing with RTTI }
   TypeInf := Component.ClassInfo;
   AName := TypeInf^.name;
   TypeData := GetTypeData(TypeInf);
   NumProps := TypeData^.PropCount;
 
 
   GetMem(PropList, NumProps*sizeof(pointer));
   try
     { Получаем список свойств }
     GetPropInfos(TypeInf, PropList);
     TagContent := '';
 
     for i := 0 to NumProps-1 do
     begin
       PropName := PropList^[i]^.name;
 
       PropTypeInf := PropList^[i]^.PropType^;
       PropInfo := PropList^[i];
 
       { Пропустить не поддерживаемые типы }
       if not (PropTypeInf^.Kind in [tkDynArray, tkArray,
       tkRecord, tkInterface, tkMethod]) then
       begin
         if TagContent <> '' then
           TagContent := TagContent + '|';
         TagContent := TagContent + PropName;
       end;
 
       case PropTypeInf^.Kind of
         tkInteger, tkChar, tkFloat, tkString,
         tkWChar, tkLString, tkWString, tkVariant,
         tkEnumeration, tkSet:
         begin
           { Перевод в DTD. Для данных типов модель содержания - #PCDATA }
           addElement(PropName, PCDATA);
         end;
 
         {
         Kод был бы полезен при использовании атрибутов
         tkEnumeration:
         begin
           TypeData:= GetTypeData(GetTypeData(PropTypeInf)^.BaseType^);
           s := '';
           for j := TypeData^.MinValue to TypeData^.MaxValue do
           begin
             if s <> '' then s := s + '|';
             s := s + GetEnumName(PropTypeInf, j);
           end;
           addElement(PropName, s);
         end;
         }
 
         tkClass: { Для классовых типов рекурсивная обработка }
         begin
           PropObject := GetObjectProp(Component, PropInfo);
           if Assigned(PropObject)then
           begin
             { Для дочерних свойств-классов - рекурсивный вызов }
             if (PropObject is TPersistent) then
               GenerateDTDInternal(PropObject, DTDList, Stream, PropName);
           end;
         end;
       end;
     end;
 
     { Индивидуальный подход к некоторым классам }
     { Для коллекций необходимо включить в модель содержания тип элемента }
     if (Component is TCollection) then
     begin
       if TagContent <> '' then
         TagContent := TagContent + '|';
       TagContent := TagContent + (Component as TCollection).ItemClass.ClassName + '*';
     end;
 
     { Добавляем модель содержания для элемента }
     addElement(ComponentTagName, TagContent);
   finally
     FreeMem(PropList, NumProps*sizeof(pointer));
   end;
 end;
 

Закоментированный код нам не нужен, но он не удален, т.к. он демонстрирует получение списка возможных значений для перечисления (Enumeration) и набора (Set). Это может понадобится, если появится необходимость генерировать свойства в виде атрибутов XML тегов и, соответственно, DTD для возможных значений этих атрибутов.




Создать динамический массив

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

Этот динамический массив основан на массиве Delphi. Поэтому обращение к нему быстро и удобно. Тип TArray – это массив нужного типа. 128 элементов можно заменить любым другим числом, хоть 0. Повлиять это может только на отладку программы, так как Delphi выведет (если уместится) именно это количество элементов. PArray – это указатель на TArray. При обращении к элементам массива для Delphi главное, чтобы этот элемент существовал в памяти, то есть, чтобы под него была выделена память. А проверять, находится ли номер нужного элемента между 0 и 127 Delphi не будет.

Главным методом объекта является SetCount. Он сделан таким образом, что при изменении количество элементом старые данные не теряются, а новые элементы всегда обнуляются.

Процедура Reset обнуляет все существующие элементы.

Для того чтобы сделать этот массив, например, массивом целых чисел нужно поменять все double на integer или еще что-то.

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


 type
 TForm1 = ...
 ...
 end;
 
   TArray = array [0..127] of double;
   PArray = ^TArray;
   TDynArray = object
   p: PArray;
   count: integer;
   constructor Create(ACount: integer); { инициализация }
   procedure SetCount(ACount: integer); { установка количества элементов }
   procedure Reset; { обнуление данных }
   destructor Destroy; { уничтожение }
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 constructor TDynArray.Create(aCount: integer);
 begin
   p := nil;
   count := 0;
   SetCount(ACount);
 end;
 
 procedure TDynArray.SetCount(ACount: integer);
 var
   np: PArray;
 begin
   if count = ACount then
   Exit;
   { память не была выделена }
   if p = nil then
   begin
     { новое количество элементов в массиве равно 0 }
     if ACount <= 0 then
     begin
       count := 0;
     end
     { новое количество элементов в массиве больше 0 }
     else
     begin
       { выделение памяти }
       GetMem(p, ACount * sizeof(double));
       { обнуление данных }
       fillchar(p^, ACount * sizeof(double), 0);
       count := ACount;
     end;
   end
   else
   begin
     { новое количество элементов в массиве равно 0 }
     if ACount <= 0 then
     begin
       { освобождение памяти }
       FreeMem(p, count * sizeof(double));
       count := 0;
     end
     else
     begin
       { выделение памяти }
       GetMem(np, ACount * sizeof(double));
       { требуется увеличить количество элементов }
       if ACount > count then
       begin
         { перемещение старых данных на новое место }
         move(p^, np^, count * sizeof(double));
         { обнуление новых элементов массива }
         fillchar(np^[count], (ACount - count) * sizeof(double), 0);
       end
       else
       begin
         { перемещение части старых данных на новое место }
         move(p^, np^, ACount * sizeof(double));
       end;
       { освобождение старой памяти }
       FreeMem(p, count * sizeof(double));
       p := np;
       count := ACount;
     end;
   end;
 end;
 
 procedure TDynArray.Reset;
 begin
   { обнуление данных }
   fillchar(p^, count * sizeof(double), 0);
 end;
 
 destructor TDynArray.Destroy;
 begin
   SetCount(0);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   a: TDynArray;
   i: integer;
   s: string;
 begin
   a.Create(3);
   a.p[0] := 10;
   a.p[1] := 20;
   { второй элемент не указывается, но вследствие обнуления
   при создании массива он равен 0 }
   s := 'Элементы в массиве:';
   for i := 0 to a.count - 1 do
     s := s + #13#10 + IntToStr(i+1) + ': ' + FloatToStr(a.p[i]);
   ShowMessage(s);
 
   a.SetCount(4);
   a.p^[3] := 50;
   { значения первых элементов не теряются }
   s := 'Элементы в массиве:';
   for i := 0 to a.count - 1 do
     s := s + #13#10 + IntToStr(i+1) + ': ' + FloatToStr(a.p[i]);
   ShowMessage(s);
 
   a.Destroy;
 end;
 




Создаём Excel файл без OLE


 const
   CXlsBof: array[0..5] of Word = ($809, 8, 00, $10, 0, 0);
   CXlsEof: array[0..1] of Word = ($0A, 00);
   CXlsLabel: array[0..5] of Word = ($204, 0, 0, 0, 0, 0);
   CXlsNumber: array[0..4] of Word = ($203, 14, 0, 0, 0);
   CXlsRk: array[0..4] of Word = ($27E, 10, 0, 0, 0);
 
 procedure XlsBeginStream(XlsStream: TStream; const BuildNumber: Word);
 begin
   CXlsBof[4] := BuildNumber;
   XlsStream.WriteBuffer(CXlsBof, SizeOf(CXlsBof));
 end;
 
 procedure XlsEndStream(XlsStream: TStream);
 begin
   XlsStream.WriteBuffer(CXlsEof, SizeOf(CXlsEof));
 end;
 
 procedure XlsWriteCellRk(XlsStream: TStream; const ACol, ARow: Word;
   const AValue: Integer);
 var
   V: Integer;
 begin
   CXlsRk[2] := ARow;
   CXlsRk[3] := ACol;
   XlsStream.WriteBuffer(CXlsRk, SizeOf(CXlsRk));
   V := (AValue shl 2) or 2;
   XlsStream.WriteBuffer(V, 4);
 end;
 
 procedure XlsWriteCellNumber(XlsStream: TStream; const ACol, ARow: Word;
   const AValue: Double);
 begin
   CXlsNumber[2] := ARow;
   CXlsNumber[3] := ACol;
   XlsStream.WriteBuffer(CXlsNumber, SizeOf(CXlsNumber));
   XlsStream.WriteBuffer(AValue, 8);
 end;
 
 procedure XlsWriteCellLabel(XlsStream: TStream; const ACol, ARow: Word;
   const AValue: string);
 var
   L: Word;
 begin
   L := Length(AValue);
   CXlsLabel[1] := 8 + L;
   CXlsLabel[2] := ARow;
   CXlsLabel[3] := ACol;
   CXlsLabel[5] := L;
   XlsStream.WriteBuffer(CXlsLabel, SizeOf(CXlsLabel));
   XlsStream.WriteBuffer(Pointer(AValue)^, L);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   FStream: TFileStream;
   I, J: Integer;
 begin
   FStream := TFileStream.Create('c:\e.xls', fmCreate);
   try
     XlsBeginStream(FStream, 0);
     for I := 0 to 99 do
       for J := 0 to 99 do
       begin
         XlsWriteCellNumber(FStream, I, J, 34.34);
         // XlsWriteCellRk(FStream, I, J, 3434); 
         // XlsWriteCellLabel(FStream, I, J, Format('Cell: %d,%d', [I, J])); 
       end;
     XlsEndStream(FStream);
   finally
     FStream.Free;
   end;
 end;
 




Динамическое создание полей

Автор: Marco Romanini (SysOp) Delphi Tech Support

День 1-й. Бог создал свет.
День 2-й. Бог создал юзера.
День 3-й. Бог создал Дос.
День 4-й. Бог создал Windows 3.11
День 5-й. Бог создал Windows
День 6-й. Бог создал женщину-юзверя.
День 7-й. Бог не в силах был что-то сделать.


 var
   I: Integer;
   Field: TField;
 begin
   { Поля можно добавлять только к неактивному набору данных. }
   Table1.Active := False;
 
   { Распределяем определенные поля если набор данных еще не был активным. }
   Table1.FieldDefs.Update;
 
   { Создаем все поля из определений и добавляем к набору данных. }
   for I := 0 to Table1.FieldDefs.Count - 1 do
   begin
     { Вот где мы действительно сообщаем набору данных о необходимости создания поля. }
     { Поле "назначается", но нам нужно не это, нам нужна просто ссылка на новое поле. }
     Field := Table1.FieldDefs[I].CreateField(Table1);
   end;
 
   { Вот пример того, как вы можете добавить дополнительные, вычисленные поля }
   Field := TStringField.Create(Table1);
   Field.FieldName := 'Total';
   Field.Calculated := True;
   Field.DataSet := Table1;
 
   { Теперь мы можем увидеть наши поля. }
   Table1.Active := True;
 end;
 




Динамическое создание полей 2

Автор: Eryk

Как мне определить на лету другое поле подобно команде "Define" в редакторе полей (Fields Editor)? (Калькулируемое поле, другими словами?)

Следующий код создаст полный набор 'default' TField для TTable и добавит затем калькулируемое поле:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   f: TField;
   i: integer;
 begin
   Table1.Close;
   for i := 0 to Table1.FieldDefs.Count - 1 do
     Table1.FieldDefs.Items[i].CreateField(Table1);
   f := TStringField.Create(Table1);
   f.Name := 'Table1CalcField';
   f.FieldName := 'CalcField';
   f.DisplayLabel := 'CalcField';
   f.Calculated := True;
   f.DataSet := Table1;
   Table1.Open;
 end;
 

...следующий пример создаст два новых TField в TTable, 'базируясь' на TField, определенных в режиме редактирования. Одно из новых полей калькулируемое, другое нет:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   f1, f2: TField;
 begin
   Table1.Close;
   f1 := TStringField.Create(Table1);
   f1.Name := 'Table1CalcField';
   f1.FieldName := 'CalcField';
   f1.DisplayLabel := 'CalcField';
   f1.Calculated := True;
   f1.DataSet := Table1;
   f2 := TFloatField.Create(Table1);
   f2.Name := 'Table1Population';
   f2.FieldName := 'Population';
   f2.DisplayLabel := 'Population';
   f2.DataSet := Table1;
   Table1.Open;
 end;
 




Создание TList со списком файлов, отсортированных по дате

Автор: MBo


 type
  PSRec=^TSearchRec;
 
 function DateCompare(Item1, Item2: Pointer): Integer;
 begin
 if PSRec(Item1)^.Time> PSRec(Item2)^.Time then Result:=1 else
 if PSRec(Item1)^.Time=PSRec(Item2)^.Time then Result:=0 else
   Result:=-1;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
 i:Integer;
 SRList:TList;
 SR:TSearchRec;
 PSR:PSRec;
 begin
 SRList:=TList.Create;
 if F SRList.Count> 1 then SRList.Sort(DateCompare);
 
 for i:=0 to SRList.Count-1 do
   Memo1.Lines.Add(PSRec(SRList.Items[i])^.Name+'     '+
     DateTimeToStr(FileDateToDateTime(PSRec(SRList.Items[i])^.Time)));
 SRList.Free;
 end;
 




Проблема получения времени создания файла

Попробуйте следующую функцию, которая не требует вызова FindFirst:


 function GetFileDate(TheFileName: string): string;
 var
   FHandle: integer;
 begin
   FHandle := FileOpen(TheFileName, 0);
   result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle)));
   FileClose(FHandle);
 end;
 

Одно маленькое предупреждение: время, возвращаемое Win32-функцией, отсчитывается от Гринвича, поэтому вам необходимо привести полученный результат к локальному времени. Чтобы быть уверенным, проверьте документацию. (Я уверен, что FindNextFile делает это правильно).




Создание фона на форме

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


 unit Unit1;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs;
 
 type
   TForm1 = class(TForm)
     procedure FormCreate(Sender: TObject);
     procedure FormPaint(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
   Bitmap: TBitmap;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Bitmap := TBitmap.Create;
   Bitmap.LoadFromFile('C:\WINDOWS\cars.BMP');
 end;
 
 procedure TForm1.FormPaint(Sender: TObject);
 var
   X, Y, W, H: LongInt;
 begin
   with Bitmap do
   begin
     W := Width;
     H := Height;
   end;
   Y := 0;
   while Y < Height do
   begin
     X := 0;
     while X < Width do
     begin
       Canvas.Draw(X, Y, Bitmap);
       Inc(X, W);
     end;
     Inc(Y, H);
   end;
 end;
 
 end.
 




Как создать новую форму, которая бы не отбирала фокус у существующей

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


 uses Unit2;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Form2 := TForm2.Create(Application);
   Form2.Visible := FALSE;
   ShowWindow(Form2.Handle, SW_SHOWNA);
 end;
 




Можно ли создать форму, которая получает дополнительные параметры в методе Сreate

Просто замените конструктор Create класса Вашей формы.


 unit Unit2;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
 
 type
   TForm2 = class(TForm)
   private
     {Private declarations}
   public
     {Public declarations}
     constructor CreateWithCaption(aOwner: TComponent; aCaption: string);
 end;
 
 var
   Form2: TForm2;
 
 implementation
 
 {$R *.DFM}
 
 constructor TForm2.CreateWithCaption(aOwner: TComponent; aCaption: string);
 begin
   Create(aOwner);
   Caption := aCaption;
 end;
 
 uses
  Unit2;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Unit2.Form2 :=Unit2.TForm2.CreateWithCaption(Application, 'My Caption');
   Unit2.Form2.Show;
 end;
 




Создание таблицы FOXPRO

До чего же несовершенна техника! Человеку, чтобы прийти в себя, необходимо два пальца, а компьютеру - три.


 if savedialog1.execute then
 begin
 if FileExists(savedialog1.filename) then
    DeleteFile(savedialog1.filename);
   //QUERY.DataSource НЕ ЗАПОЛНЕНО иначе взрыв гарантирован
 with Session do
 begin
     ConfigMode := cmSession;
   try
    AddStandardAlias('TEMPDB', extractfilepath(savedialog1.filename),
     'FOXPRO'); //FOXPRO
   finally
       ConfigMode := cmAll;
   end;
 end;
  with database1 do
  begin
    databasename:='tst';
    LoginPrompt := False;
    Params.Values['PATH'] :=extractfilepath(savedialog1.filename);
    DriverName:='Microsoft FoxPro Driver (*.dbf)';
    AliasName:='TEMPDB';
  end;
  query1.paramcheck := false;
  Query1.DatabaseName := 'tst';
  Query1.SQL.Clear;
  vrem:=Trim(ChangeFileExt(extractfilename(SaveDialog1.fileName),' '));
  query1.sql.Add('CREATE TABLE '''+vrem+''' (');
  query1.sql.Add('last_name CHAR(20),');
  query1.sql.Add('first_name CHAR(15),');
  query1.sql.Add('salary DECIMAL(10,2));');  //NUMERIC
  query1.ExecSQL;
  query1.close;
 end; // от savedialog
 




Создание ловушек (Hook) в Delphi

Рано или поздно каждый программист сталкивается с таким понятим как ловушки. Чтобы приступить к ипользованию ловушек необходимо обзавестись windows SDK, который можно так же скачать с сайта Microsoft. В прилагаемом к статье архиве содержатся два проекта: hooks.dpr - это пример приложения работающего с ловушками, а hookdll.dpr - собственно сама DLL.

Что такое ловушки (Hooks)?

Проще говоря, ловушка - это функция, которая является частью DLL или часть Вашего приложения, при помощи которой можно контролировать 'происходящее' внутри окошек операционной системы. Идея состоит в том, чтобы написать функцию, которая будет вызываться каждый раз, когда будет возникать определённое событие - например, когда пользователь нажмёт клавишу или переместит мышку. Ловушки были задуманы Microsoft в первую очередь, чтобы облегчить программистам отладку приложений. Однако существует множество способов использования ловушек - например, чаще всего при помощи ловушек пишутся клавиатурные шпионы.

Итак, существует два типа ловушек - глобальные и локальные. Локальная ловушка отслеживает только те события, которые происходят только в одной программе (или потоке). Глобальная ловушка отслеживает события во всей системе (во всех потоках). Оба типа ловушек устанавливаются одинаково, однако единственно отличие заключается в том, что локальная ловушка вызывается в пределах Вашего приложения, в то время как глобальную ловушку необходимо хранить и вызывать из отдельной DLL.

Процедуры ловушки

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

  • Функция SetWindowsHookEx

Функция SetWindowsHookEx необходима для установки ловушки. Давайте посмотрим на аргументы данной функции:

Name Type Description
idHook Integer Число, представляющее тип ловушки - например WH_KEYBOARD
lpfn TFNHookProc Адрес в памяти функции ловушки
hMod Hinst Дескриптор dll в которой находится функция. Если это локальная ловушка, то этот параметр 0.
dwThreadID Cardinal 'id потока', который Ваша программа будет контролировать. Если это глобальная ловушка, то параметр должен быть 0.
     

SetWindowsHookEx возвращает дескриптор (т.е. идентификатор) текущей ловушки, который можно использовать в функции UnhookWindowsHookEx для последующего удаления ловушки.

  • Функция hook

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

Name Type Description
Code Integer Указывает на то, что означают следующие два параметра
wParam word Параметр размером в 1 слово (word)
lParam longword Параметр размером в 2 слова
     

Функция hook возвращает значение типа longword.

  • Функция CallNextHookEx

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

  • Функция UnhookWindowsHookEx

Данная функция просто напросто удаляет Вашу ловушку. Единственный аргумент этой функции - это дескриптор ловушки, возвращаемы функцией SetWindowsHookEx.

Локальная ловушка

Сперва давайте создадим локальную ловушку. Необходимый для неё код содержится в 'local.pas'. При запуске Hooks.exe будет отображена небольшая форма. Для использования локальной ловушки достаточно нажать кнопку Add/Remove Local Hook на этой форме. После установки локальной ловушки, Вы заметите, что при нажатии и отпускании любой клавиши будет раздаваться звуковой сигнал (естевственно, когда hooks.exe будет иметь фокус. Ведь это локальная ловушка).

Самая первая функция в local.pas - SetupLocalHook, которая соственно и создаёт локальную ловушку, указывая на процедуру ловушки KeyboardHook. В данном случае это простой вызов SetWindowsHookEx, и, если возвращённый дескриптор > 0, указывающий на то, что процедура работает, то сохраняет этот дескриптор в CurrentHook и возвращает true, иначе будет возвращено значение false. Далее идёт функция RemoveLocalHook, которая получает в качестве параметра сохранённый дескриптор в CurrentHook и использует его в UnhookWindowsHookEx для удаления ловушки. Последняя идёт процедура hook, которая всего навсего проверяет - была ли отпущена клавиша и если надо, то выдаёт звуковой сигнал.

Глобальная ловушка

Глобальная ловушка выглядит немного сложнее. Для создания глобальной ловушки нам понадобится два проекта - певый для создания исполняемого файла и второй для создания DLL, содержащей процедуру ловушки. Глобальная ловушка, которая представлена в примере, сохраняет в файле log.txt каждые 20 нажатий клавиш. Чтобы использовать глобальную ловушку, достаточно на форме hook.exe нажать кнопку add/remove global hook. Затем, например, в записной книжке (notepad) достаточно набрать какой-нибудь текст, и Вы увидите, что в log.txt этот текст сохранится.

Наша Dll содержит две процедуры. Первая - это процедура hook, которая идентична для той, которую мы рассмотрели для локальной ловушки. Вторая процедура необходима инициализации dlls, и содержит текущий номер клавиши, которая была нажата, а также дескриптор ловушки, которая была создана.

Исполняемый файл сперва должен загрузить процедуры из DLL, а затем использовать SetWindowsHookEx, чтобы создать глобальную ловушку.

В заключении...

Представленный пример объясняет - как перехватывать события клавиатуры. Чтобы узнать, как использовать ловушки других типов, таких как WH_MOUSE, необходимо разобраться с windows SDK.




Создание уникального табличного индекса

Автор: Галимарзанов Фанис

Очень часто требуется решить проблему уникальности индекса для таблиц - не всегда можно дополнять ключ меткой времени. Для этого можно использовать метод TTable.OnPostError.
При создании таблицы добавляем поле Ax типа ftInteger или ftSmallInt, которое будет замыкать ключевые поля. К примеру, необходимо создать таблицу платежей абонентов, в которой могут существовать несколько платежей, проведенных в один день.

 abKod         : код абонента, входит в первичный ключ
 Data          : дата платежа, входит в первичный ключ
 Ax            : дополнительное поле, входит в первичный ключ и замыкает
 его
 TypeOpl       : тип оплаты
 Summ          : сумма платежа

В примере уникальность ключа можно обеспечить за счет поля Data, но это достигается за счет включения кода вида


 taOplData.Value:=taOplData.Value+Time;
 

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

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


 const
   eKeyViol = 9729; // код ошибки BDE - нарушение уникальности записи
 
 procedure TForm1.Table1PostError(DataSet: TDataSet; E: EDatabaseError;
   var Action: TDataAction);
 begin
   if (E is EDBEngineError) then // здесь обычный код распознавания кода ошибки
     if (E as EDBEngineError).Errors[0].Errorcode = eKeyViol then
     begin
       DataSet.FieldByName('Ax').Value := DataSet.FieldByName('Ax').Value + 1;
       // Увеличиваем значение поля Ax и повторяем попытку Post
       Action := daRetry; // повторить операцию сохранения
     end;
 end;
 

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




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


 Table1.AddIndex('ИмяИндекса', 'СписокПолей', [опции]); // Подробнее в хелпе
 




Создание индексного файла из Delphi

Законы программизма от Ваще.
1. Ничто не работает так, как планировалось запрограммировать.
2. Ничто не программируется так, как должно работать.
3. Хороший программист характеризуется умением доказать почему задачу невозможно выполнить, когда ему просто лень её выполнять.
4. На решение проблемы уходит в три раза меньше времени, чем на обсуждение всех "за" и "против" её решения.
5. Обещанный срок сдачи - это аккуратно расчитанная дата окончания проекта плюс шесть месяцев.
6. Программисту всегда известна последовательность действий, которыми пользователь может повесить его программу, но он никогда не чинит эту проблему, надеясь на то, что никому никогда не придёт в голову эту последовательность исполнять.
7. Настоящие программисты любят Windows - все ошибки, сделанные по собственной тупости, можно свалить на Microsoft.
8. Следствие - 99% проблем, сваливаемых на Microsoft, является следствием тупости самих программистов.
9. В приступе злости все почему-то молотят по невинному монитору, вместо системного блока.
10. В случае голодовки настоящий программист ещё месяц сможет питатся едой, выковырянной из-под кнопок клавиатуры.
11. Настоящий программист уже как минимум поменял три залитых пивом клавиатуры.
12. Все, кто испытывает проблемы с настройкой кодировки, автоматически считаются неандертальцами.
13. Дилетантские разговоры о компьютерах вызывают резкую тошноту влоть до приступов рвоты. Вопрос о том как поменять "обои" в Windows вызывает желание перерезать горло вопрошающему.
14. У большинства людей, нуждающихся в твоей помощи, причина ошибки в работе программы чисто генетическая.
15. HTML, HTTP, FTP, SMTP, TCP/IP, RTFM и т.д. - это слова, а не аббревиатуры.
16. Словосочетание "мышка-норушка" не несёт никакого смысла.
17. Самые мистические проблемы, широко раздуваемые и афишируемые, в конце концов оказываются твоими глупейшими ошибками.
18. Следствие - если твоя программа выполняет мистические действия, значит, ты сделал что-то невероятно тупое.
19. Самое плохое ощущение для программиста - когда вокруг тебя стоят десять человек и все пытаются найти причину проблемы в твоей программе, а ты уже понял, в чём проблема, но боишься сказать, потому что это что-то вопиюще глупое...
20. Решение всех жизненных проблем находится на интернете. Надо только уметь хорошо искать.
21. Конфликт логических указаний в жизни вызывает фатальную ошибку в работе мозга программиста - возможно повышение температуры и сильное головокружение вплоть до рвоты или потери сознания.
22. Тех, кто презирает программистов, программисты презирают сильнее, чем те, кто презирает программистов, презирающих программистов, которые презирают тех, кто их презирает.
23. Если ты понял предыдущее - то ты программист.

Если вы используете таблицы dBASE или Paradox, то для создания нового индекса воспользуйтесь методом AddIndex. Для примера:


 Table1.AddIndex('Articles','Title', []) ;
 

создаст индексный файл с именем ARTICLES с использованием поля TITLE в качестве индексного ключа. При создании вы можете воспользоваться различными индексными опциями (например, уникальность, необслуживаемый и пр.) -- для получения дополнительной информации обратитесь к электронной справке по Delphi. ПРИМЕЧАНИЕ: Ваша таблица должна быть открыта исключительно для того, чтобы только воспользоваться методом AddIndex.

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




Программно создать ярлык


Автор: Gavrilo

Прежде чем вставить дискету в дисковод, проверьте ее на вирусы!!!

Для начала подключите следующие модули:


 uses
   ShlObj, ComObj, ActiveX;
 

А затем используёте процедуру создания ярлыка:


 procedure CreateLink(const PathObj, PathLink, Desc, Param: string);
 var
   IObject: IUnknown;
   SLink: IShellLink;
   PFile: IPersistFile;
 begin
   IObject := CreateComObject(CLSID_ShellLink);
   SLink := IObject as IShellLink;
   PFile := IObject as IPersistFile;
   with SLink do
   begin
     SetArguments(PChar(Param));
     SetDescription(PChar(Desc));
     SetPath(PChar(PathObj));
   end;
   PFile.Save(PWChar(WideString(PathLink)), FALSE);
 end;
 




Программно создать ярлык 2


Автор: VRSLazy@mail.ru

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

Может ещё так можно ярлыки делать?


 // не помню какая из них нужна, вообще наити можно поиском в *.pas в каталоге
 uses...ShlObj, ComObj, ActiveX, shellapi, ComCtrls, ...
 // disk:\Program Files\Borland\Delphi5\Source
 
 procedure SetShortCut(path, cmd, icon, wd, name, arg: string);
 var
   ShellObject: IUnknown;
   LinkFile: IPersistFile;
   ShellLink: IShellLink;
 begin
   try
     CoInitialize(nil);
     ShellObject := CreateComObject(CLSID_ShellLink);
     LinkFile := ShellObject as IPersistFile;
     ShellLink := ShellObject as IShellLink;
       // RTFM - интерфейсу IShellLink, там вс? описано
     ShellLink.SetPath(@cmd[1]);
     ShellLink.SetWorkingDirectory(@wd[1]);
     ShellLink.SetIconLocation(@icon[1], 0);
       // вместо 0 можно указать номер иконки если их там много...
     ShellLink.SetDescription(@name[1]);
     ShellLink.SetArguments(@arg[1]);
     LinkFile.Save(PWChar(WideString(path)), true);
   finally
     ShellObject := Unassigned;
     CoUninitialize;
   end;
 end;
 




Программно создать ярлык 3


Автор: Nomadic

Пpогpаммист увидел HЛО:
- У кого-то диск полетел...


 function CreateShortcut(const CmdLine, Args, WorkDir, LinkFile: string):
   IPersistFile;
 var
   MyObject: IUnknown;
   MySLink: IShellLink;
   MyPFile: IPersistFile;
   WideFile: WideString;
 begin
   MyObject := CreateComObject(CLSID_ShellLink);
   MySLink := MyObject as IShellLink;
   MyPFile := MyObject as IPersistFile;
   with MySLink do
   begin
     SetPath(PChar(CmdLine));
     SetArguments(PChar(Args));
     SetWorkingDirectory(PChar(WorkDir));
   end;
   WideFile := LinkFile;
   MyPFile.Save(PWChar(WideFile), False);
   Result := MyPFile;
 end;
 
 procedure CreateShortcuts;
 var
   Directory, ExecDir: string;
   MyReg: TRegIniFile;
 begin
   MyReg := TRegIniFile.Create(
     'Software\MicroSoft\Windows\CurrentVersion\Explorer');
 
   ExecDir := ExtractFilePath(ParamStr(0));
   Directory := MyReg.ReadString('Shell Folders', 'Programs', '') + '\' +
     ProgramMenu;
 
   CreateDir(Directory);
   MyReg.Free;
 
   CreateShortcut(ExecDir + 'Autorun.exe', '', ExecDir,
     Directory + '\Demonstration.lnk');
   CreateShortcut(ExecDir + 'Readme.txt', '', ExecDir,
     Directory + '\Installation notes.lnk');
   CreateShortcut(ExecDir + 'WinSys\ivi_nt95.exe', '', ExecDir,
     Directory + '\Install Intel Video Interactive.lnk');
 end;
 

Разберешься?

Гм. Вообще правильнее в процедуре CreateShortcuts пользовать Win32API::GetSpecialFolderLocation с нужным параметром (CSIDL_PROGRAMS в случае папки "Программы", или CSIDL_DESKTOP в случае "Рабочего стола").




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


 uses
   Forms, Classes, Controls, StdCtrls, Db, DBTables, DBCtrls;
 
 
 type
   TForm1 = class(TForm)
     Table1: TTable; // DBDemos customer table
     Table2: TTable; // DBDemos orders table
     Button1: TButton;
     DBLookupComboBox1: TDBLookupComboBox;
     DataSource1: TDataSource;
     Table2CustNo: TFloatField; // CustNo key field object used for Lookup
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   with TStringField.Create(Table2) do
   begin
     FieldName := 'MyLookup';
     FieldKind:= fkLookup;
     DataSet := Table2;
     name := Dataset.name + FieldName;
     KeyFields:= 'CustNo';
     LookUpDataset:= Table1;
     LookUpKeyFields:= 'CustNo';
     LookUpResultField:= 'Company';
     DbLookupCombobox1.DataField:= FieldName;
     DataSource1.DataSet:= Dataset;
     Table2.FieldDefs.Add(name, ftString, 20, false);
   end;
   DbLookupCombobox1.DataSource:= Datasource1;
   Table1.Active:= True;
   Table2.Active:= True;
 end;
 
 end.
 




Создание множества экземпляров


 list:=Tlist.create;
 
 For i:= 1 to 1000 do
 begin
   SSObject:=TSSObject.create;
   {поместите куда-нибудь ссылку на созданный объект - например, в Tlist}
   list.add(SSObject);
 end;
 




Создать, изменить и удалить TrayIcon

В программах для Window 95 и выше часто используется TrayIcon – иконка справа на TaskBar, которая позволяет программе почти не занимать места на экране и при этом быть всегда доступной. Для работы с TrayIcon используется функция Shell_NotifyIcon, в которую передается команда: NIM_ADD, NIM_MODIFY или NIM_DELETE для создания изменения и удаления соответственно, и структура TNotifyIconData. У каждой TrayIcon в вашем приложении должен быть свой uID.


 const
   WM_NOTIFYTRAYICON = WM_USER + 1;
 ...
 private
   procedure WMTRAYICONNOTIFY(var Msg: TMessage); message WM_NOTIFYTRAYICON;
 ...
 uses
   ShellAPI;
 
 procedure TForm1.WMTRAYICONNOTIFY(var Msg: TMessage);
 var
   s: string;
 begin
   case Msg.LParam of
     WM_MOUSEMOVE:     s := 'Мышь сдвинута';
     WM_LBUTTONDOWN:   s := 'Левая кнопка нажата';
     WM_LBUTTONUP:     s := 'Левая кнопка отпущена';
     WM_LBUTTONDBLCLK: s := 'Два раза нажата левая кнопка';
     WM_RBUTTONDOWN:   s := 'Правая кнопка нажата';
     WM_RBUTTONUP:     s := 'Правая кнопка отпущена';
     WM_RBUTTONDBLCLK: s := 'Два раза нажата правая кнопка';
     else              s := IntToStr(Msg.LParam);
   end;
   ListBox1.Items.Add(s);
   ListBox1.ItemIndex := ListBox1.Items.Count - 1;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   tray: TNotifyIconData;
   Ic: TIcon;
 begin
   Ic := TIcon.Create;
   Ic.LoadFromFile('Icon1.ico');
   with tray do
   begin
     cbSize := SizeOf(TNotifyIconData);
     Wnd := Form1.Handle;
     uID := 1;
     uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
     uCallBackMessage := WM_NOTIFYTRAYICON;
     hIcon := Ic.Handle;
     szTip := ('Это наша иконка');
   end;
   Shell_NotifyIcon(NIM_ADD, Addr(tray));
   Ic.Destroy;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   tray: TNotifyIconData;
   Ic: TIcon;
 begin
   Ic := TIcon.Create;
   Ic.LoadFromFile('Icon2.ico');
   with tray do
   begin
     cbSize := SizeOf(TNotifyIconData);
     Wnd := Form1.Handle;
     uID := 1;
     uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
     uCallBackMessage := WM_NOTIFYTRAYICON;
     hIcon := Ic.Handle;
     szTip := ('Это другая иконка');
   end;
   Shell_NotifyIcon(NIM_MODIFY, Addr(tray));
   Ic.Destroy;
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 var
   tray: TNotifyIconData;
 begin
   with tray do
   begin
     cbSize := SizeOf(TNotifyIconData);
     Wnd := Form1.Handle;
     uID := 1;
   end;
   Shell_NotifyIcon(NIM_DELETE, Addr(tray));
 end;
 




Создание нового WAV-файла

Данный документ был создан по многочисленным просьбам пользователей и описывает дополнительную функциональность компонента Delphi TMediaPlayer. Новая функциональность компонента заключается в возможности создания при записи нового файла формата .wav. Процедура "SaveMedia" создает тип record, передаваемый команде MCISend. Существует исключение, которое вызывает закрытие медиа при любой ошибке, возникающей при открытии определенного файла. Приложение состоит из двух кнопок. Button1 вызывает по-порядку процедуры OpenMedia и RecordMedia. Процедура CloseMedia вызывается при генерации приложением исключительной ситуации. Button2 вызывает процедуры StopMedia,SaveMedia и CloseMedia.


 unit utestrec;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, MPlayer, MMSystem, StdCtrls;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     Button2: TButton;
     procedure Button1Click(Sender: TObject);
     procedure Button2Click(Sender: TObject);
     procedure FormCreate(Sender: TObject);
     procedure AppException(Sender: TObject; E: Exception);
   private
     FDeviceID: Word;
     { Private declarations }
   public
     procedure OpenMedia;
     procedure RecordMedia;
     procedure StopMedia;
     procedure SaveMedia;
     procedure CloseMedia;
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 var
   MyError, Flags: Longint;
 
 procedure TForm1.OpenMedia;
 var
   MyOpenParms: TMCI_Open_Parms;
   MyPChar: PChar;
   TextLen: Longint;
 begin
   Flags := mci_Wait or mci_Open_Element or mci_Open_Type;
   with MyOpenParms do
   begin
     dwCallback := Handle; // TForm1.Handle
     lpstrDeviceType := PChar('WaveAudio');
     lpstrElementName := PChar('');
   end;
   MyError := mciSendCommand(0, mci_Open, Flags,
     Longint(@MyOpenParms));
   if MyError = 0 then
     FDeviceID := MyOpenParms.wDeviceID;
 end;
 
 procedure TForm1.RecordMedia;
 var
   MyRecordParms: TMCI_Record_Parms;
   TextLen: Longint;
 begin
   Flags := mci_Notify;
   with MyRecordParms do
   begin
     dwCallback := Handle; // TForm1.Handle
     dwFrom := 0;
     dwTo := 10000;
   end;
   MyError := mciSendCommand(FDeviceID, mci_Record, Flags,
     Longint(@MyRecordParms));
 end;
 
 procedure TForm1.StopMedia;
 var
   MyGenParms: TMCI_Generic_Parms;
 begin
   if FDeviceID <> 0 then
   begin
     Flags := mci_Wait;
     MyGenParms.dwCallback := Handle; // TForm1.Handle
     MyError := mciSendCommand(FDeviceID, mci_Stop, Flags,
       Longint(@MyGenParms));
   end;
 end;
 
 procedure TForm1.SaveMedia;
 type // не реализовано в Delphi
   PMCI_Save_Parms = ^TMCI_Save_Parms;
   TMCI_Save_Parms = record
     dwCallback: DWord;
     lpstrFileName: PAnsiChar; // имя файла, который нужно сохранить
   end;
 var
   MySaveParms: TMCI_Save_Parms;
 begin
   if FDeviceID <> 0 then
   begin
     // сохраняем файл...
     Flags := mci_Save_File or mci_Wait;
     with MySaveParms do
     begin
       dwCallback := Handle;
       lpstrFileName := PChar('c:\message.wav');
     end;
     MyError := mciSendCommand(FDeviceID, mci_Save, Flags,
       Longint(@MySaveParms));
   end;
 end;
 
 procedure TForm1.CloseMedia;
 var
   MyGenParms: TMCI_Generic_Parms;
 begin
   if FDeviceID <> 0 then
   begin
     Flags := 0;
     MyGenParms.dwCallback := Handle; // TForm1.Handle
     MyError := mciSendCommand(FDeviceID, mci_Close, Flags,
       Longint(@MyGenParms));
     if MyError = 0 then
       FDeviceID := 0;
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   OpenMedia;
   RecordMedia;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   StopMedia;
   SaveMedia;
   CloseMedia;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Application.OnException := AppException;
 end;
 
 procedure TForm1.AppException(Sender: TObject; E: Exception);
 begin
   CloseMedia;
 end;
 
 end.
 




Создание страниц компонента Notebook во время работы приложения


 procedure TForm1.Button1Click(Sender: TObject);
 var
   NewPage: TWinControl;
 begin
   TabbedNotebook1.Pages.Add(Edit1.Text);
   NewPage := TabbedNotebook1.Pages.Objects[TabbedNotebook1.Pages.Count - 1]
     as TWinControl;
   with TLabel.Create(Self) do
   begin
     Left := 20;
     Top := 20;
     Caption := '&Телефон: ';
     Parent := NewPage;
   end;
   with TEdit.Create(Self) do
   begin
     Left := 100;
     Top := 20;
     Text := '1-800-555-1212';
     Parent := NewPage;
   end;
 end;
 




Создание объектных переменных

В новостной группе я несколько раз встречал вопросы подобного плана, указывающие на недостаток понимания работы экземпляра объекта. Я понимаю, что данный вопрос могут задать скорее новички в программировании, поэтому свой рассказ я начну издалека - с организации классов в Delphi. Я надеюсь, что моя "попытка" ликбеза по крайней мере объяснит суть предмета.

Во всяком случае, рекомендую данный материал для всех, кто хоть раз сталкивался с ошибками указателей, исключительными ситуациями и GPF.

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


 var
   MyVar: TMyClass;
 

....всех вас интересует: что делает в этом случае компилятор и достаточно ли распределено памяти, чтобы хранить указатель на экземпляр данного класса в куче памяти. Знайте же: вы не распределили память для данного класа, вы только что распределили память для указателя. Компилятор всегда инициализирует этот указатель в $FFFFFFFF, а это значит, что распределенный блок памяти пуст. Во всяком случае этого достаточно, чтобы сказать что указатель *не* указывает на верную "позицию" памяти и ваш класс *не* содержит никаких данных.

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


 MyVar := TMyClass.Create;
 

Это действительно просто, поскольку метод конструктора Create класса TMyClass является классовым методом - он работает в классе, а не в отдельном объекте. Когда вы вызываете конструктор, Delphi распределяет память и возвращает значение указателя. Присмотритесь: не похоже ли это на вызов функции? Хорошо, если вы раньше не знали, что возвращалось при вызове, то теперь вы это знаете. Вызов TMyClass.Create возвращает указатель на объект типа TMyClass.

В конце концов то, что вам действительно нужно помнить, это...

  1. Объявление объектной переменной некоторого типа.
  2. Создание объекта вызовом метода конструктора класса.
  3. Использование объекта по назначению.
  4. Освобождение объекта.

 procedure Example;
 var
   MyObj: TMyClass;   // класс, который вы создаете
   MyList: TList;     // встроенный класс
 begin
   MyObj := TMyClass.Create;
   // теперь MyObj содержит адрес блока памяти,
   // распределенной для экземпляра вашего класса
   MyList := TList.Create;
   // Код для работы с MyList
   // ....
   // здесь что-то делаем с объектом
   // ....
   MyList.Free;
   // Ресурсы MyList удаляются из кучи
   MyObj.Free;
   // тоже самое для MyObj
 end;
 




Создать ярлык объекта в любой папке

- Дискеты не нужны?
- А новые?
- Еще девочки.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   MyObject: IUnknown;
   MyIcon: IShellLink;
   MyPFile: IPersistFile;
   FileName: string;
   Directory: string;
   WFileName: WideString;
   MyReg: TRegIniFile;
 begin
   MyObject := CreateComObject(CLSID_ShellLink);
   MyIcon := MyObject as IShellLink;
   MyPFile := MyObject as IPersistFile;
   //Указать что является запускающей программой
   FileName := 'C:\Project.exe';
   with MyIcon do
   begin
     // Какой файл подвергаеться воздействию запускающей программы
     SetArguments('C:\Project.exe');
     //Установить путь к запускающему файлу
     SetPath(PChar(FileName));
     // Установить рабочую директорию
     SetWorkingDirectory(PChar(ExtractFilePath(FileName)));
   end;
   MyReg :=
     TRegIniFile.Create('Software\MicroSoft\Windows\CurrentVersion\Explorer');
 
   {Begin_Чтобы положить ярлык на Desktop}
   Directory := MyReg.ReadString('Shell Folders', 'Desktop', '');
   {End_Чтобы положить ярлык на Desktop}
 
   {Begin_Чтобы положить ярлык в start menu}
   //{Directory := MyReg.ReadString('Shell Folders','Start Menu','')+
   // '\Whoa!'; //CreateDir(Directory);
   {End_Чтобы положить ярлык в start menu}
 
   {Begin_Чтобы положить ярлык в любую директор.}
   //Directory := 'c:\windows\desktop';
   {End_Чтобы положить ярлык в любую директор.}
 
   WFileName := Directory + '/ShortCut1.lnk';
   MyPFile.Save(PWChar(WFileName), False);
   MyReg.Free;
 end;
 




Как в Oracle создать sequence с некоторого номера

Автор: Nomadic


create sequence minvalue 10;




Как создать собственное Hint-окно

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


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Timer1.Enabled := false;
   Panel1.Visible := false;
   Panel1.BevelInner := bvNone;
   Panel1.BevelOuter := bvNone;
   Panel1.BorderStyle := bsSingle;
   Panel1.Color := clWhite;
   Button1.Hint := 'Hint test';
 end;
 
 procedure TForm1.ShowAHint(x: integer;
   y: integer;
   Caption: string;
   Duration: LongInt);
 var
   dc: hdc;
   OldFont: hFont;
   pt: TSize;
   p: pChar;
 begin
   if Timer1.Enabled <> false then
     Timer1.Enabled := false;
   Timer1.Enabled := false;
   if Panel1.Visible <> false then
     Panel1.Visible := false;
   if Caption = '' then
     exit;
   Panel1.Caption := caption;
   {Get the width of the caption string}
   GetMem(p, Length(Panel1.Caption) + 1);
   StrPCopy(p, Panel1.Caption);
   dc := GetDc(Panel1.Handle);
   OldFont := SelectObject(dc, Panel1.Font.Handle);
   GetTextExtentPoint32(dc, p, Length(Panel1.Caption), pt);
   SelectObject(dc, OldFont);
   ReleaseDc(Panel1.Handle, Dc);
   FreeMem(p, Length(Panel1.Caption) + 1);
   {Position and show the panel}
   Panel1.Left := x;
   Panel1.Top := y;
   Panel1.Width := pt.cx + 6;
   Panel1.Height := pt.cy + 2;
   Panel1.Visible := true;
   {Fire off the timer to hide the panel}
   Timer1.Interval := Duration;
   Timer1.Enabled := true;
 end;
 
 procedure TForm1.Timer1Timer(Sender: TObject);
 begin
   if Panel1.Visible <> false then
     Panel1.Visible := false;
   Timer1.Enabled := false;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   {Let the button repaint}
   Application.ProcessMessages;
   ShowAHint(Button1.Left,
     Button1.Top + Button1.Height + 6,
     Button1.Hint,
     2000);
 end;
 




Код создания палитры


 var
   Form1: TForm1;
   blueVal: Byte;
   BluePalette: HPalette;
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
 
   LogicalPalette: PLogPalette;
   ColorIndex: LongInt;
 begin
   GetMem(LogicalPalette, (SizeOf(TLogPalette) + SizeOf(TPaletteEntry) * 256));
   GetSystemPaletteEntries(Canvas.Handle, 0, 256,
     LogicalPalette^.palPalEntry[0]);
   with LogicalPalette^ do
 
   begin
     palVersion := $300;
     palNumEntries := 256;
 {$R-}
     for ColorIndex := 10 to 245 do
       with palPalEntry[ColorIndex] do
       begin
         peRed := 0;
         peGreen := 0;
         peBlue := 255 - (ColorIndex - 10);
         peFlags := PC_NOCOLLAPSE;
       end;
   end;
 {$R+}
   BluePalette := CreatePalette(LogicalPalette^);
   FreeMem(LogicalPalette, (SizeOf(TLogPalette) + SizeOf(TPaletteEntry) * 256));
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
 
   DeleteObject(BluePalette);
 end;
 
 procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
 
   Shift: TShiftState; X, Y: Integer);
 var
 
   OldPal: HPALETTE;
 begin
 
   OldPal := SelectPalette(Canvas.Handle, BluePalette, False);
   RealizePalette(Canvas.Handle);
   canvas.pen.color := $02000000 or (BlueVal * $00010000);
   canvas.pen.width := 10;
   canvas.moveto(0, 0);
   canvas.lineto(X, Y);
   SelectPalette(Canvas.Handle, OldPal, False);
   Inc(BlueVal);
 
   if BlueVal > 255 then
     BlueVal := 0;
 end;
 




Для создания панелей в двумя полосами слева, которые можно двигать

Для создания панелей в двумя полосами слева, которые можно двигать друг относительно друга, используют компонент ControlBar (вкладка Additional), на котором обычно размещают один или несколько ToolBar (вкладка Win32). Чтобы сделать возможным "вытаскивание" панели из ControlBar нужно написать следующий код:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   ToolBar1.DockSite := true;
   ToolBar1.DragKind := dkDock;
   ToolBar1.DragMode := dmAutomatic;
 end;
 
 procedure TForm1.ControlBar1DockOver(Sender: TObject;
   Source: TDragDockObject; X, Y: Integer; State: TDragState;
   var Accept: Boolean);
 begin
   Accept := (Source.Control is TToolBar);
   if Accept then
     with Source.DockRect do
     begin
       TopLeft := ControlBar1.ClientToScreen(ControlBar1.ClientRect.TopLeft);
       Right := Left + Source.Control.Width;
       Bottom := Top + Source.Control.Height;
     end;
 end;
 

Вы можете убрать метод FormCreate, установив нужные свойства компонента ToolBar1 на стадии разработки при помощи Object Inspector.




Создание потомка от класса зарегистрированного в Delphi

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

Для этого определим следующим образом новый тип:


 type
   TMyPanel = class(TPanel)
   public
     procedure CMMouseEnter (var message: TMessage); message CM_MOUSEENTER;
     procedure CMMouseLeave (var message: TMessage); message CM_MOUSELEAVE;
 end;
 

Называться наш новый класс будет TMyPanel. Определить его можете до определение класса формы, т.е. сразу после директивы uses.

После объявления экземпляра формы нужно объявить экземпляр нашего нового класса:


 var
   Form1: TForm1;
   MyPanel1: TMyPanel;
 

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


 procedure TMyPanel.CMMouseEnter (var message: TMessage);
 begin
   Form1.Label1.Caption := 'Мышь на панели';
 end;
 
 procedure TMyPanel.CMMouseLEAVE (var message: TMessage);
 begin
   Form1.Label1.Caption : ='Мышь вне панели';
 end;
 

По созданию окна создаём экземпляр нашего класса:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   MyPanel1 := TMyPanel.Create(self);
   with MyPanel1 do
   begin
     Parent := Form1;
     Visible := true;
     Left := 100;
     Top := 100;
   end;
 end;
 

По уничтожению окна, соответственно, - уничтожаем:


 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   MyPanel1.Destroy;
 end;
 




Создание таблицы Paradox

Вот маленький кусочек кода для создания таблицы Paradox:


 with TTable.create(self) do
 begin
   DatabaseName := 'C:\temp';
   TableName := 'FOO';
   TableType := ttParadox;
   with FieldDefs do
   begin
     Add('Age', ftInteger, 0, True);
     Add('Name', ftString, 25, False);
     Add('Weight', ftFloat, 0, False);
   end;
   IndexDefs.Add('MainIndex', 'IntField', [ixPrimary, ixUnique]);
   CreateTable;
 end;
 




Принцип создания плагинов в Delphi

Иногда нужные мысли приходят после того, как программа сдана заказчику. Для этого придумали плугины. Плугины - это простая dll библиотека, в которой обязательно присутствует ряд процедур и функций, которые выполняют определенные разработчиком действия, например (из моей практики):


 function PluginType : PChar;
 

функция, определяющая назначение плугина.


 function PluginName : PChar;
 

функция, которая возвращает название плугина. Это название будет отоброжаться в меню.


 function PluginExec(AObject: ТТип): boolean;
 

главный обработчик, выполняет определённые действия и возвращает TRUE;

и ещё, я делал res файл с небольшим битмапом и компилировал его вместе с плугином, который отображался в меню соответствующего плугина. Откомпилировать res фaйл можно так:

  1. создайте файл с расширением *.rc
  2. напишите в нём : bitmap RCDATA LOADONCALL 1.bmp где bitmap - это идентификатор ресурса RCDATA LOADONCALL - тип и параметр 1.bmp - имя локального файла для кампиляций
  3. откомпилируйте этот файл программой brcc32.exe, лежащей в папке ...\Delphi5\BIN\ .

Загрузка плагина

Перейдём к теоретической части.

Раз плугин это dll значит её можно подгрузить следующими способами:

  • Прищипыванием её к программе!

 function PluginType : PChar; external 'myplg.dll';
 // в таком случае dll должна обязательно лежать возле exe и мы не можем передать
 // туда конкретное имя! не делать же все плугины одного имени! это нам не подходит.
 // Программа просто не загрузится без этого файла! Выдаст сообщение об ошибке.
 // Этот способ может подойти для поддержки обновления вашей программы!
 

  • Динамический

это означает, что мы грузим её так, как нам надо! Вот пример:


 var
   // объявляем процедурный тип функции из плугина
   PluginType: function: PChar;
   //объявляем переменную типа хендл в которую мы занесём хендл плугина
   PlugHandle: THandle;
 
 procedure Button1Click(Sender: TObject);
 begin
   //грузим плугин
   PlugHandle := LoadLibrary('MYplg.DLL');
   //Получилось или нет?
   if PlugHandle <> 0 then
   begin
     // ищем функцию в dll
     @PluginType := GetProcAddress(plugHandle,'Plugintype');
     if @PluginType <> nil then
       //вызываем функцию
       ShowMessage(PluginType);
   end;
   //освобождаем библиотеку
   FreeLibrary(LibHandle);
 end;
 

Вот этот способ больше подходит для построения плугинов!

Функции:


 //как вы поняли загружает dll и возвращает её хендл
 function LoadLibrary(lpLibFileName : Pchar):THandle;
 // пытается найти обработчик в переданной ей хендле dll,
 // при успешном выполнении возвращает указатель обработчика.
 function GetProcAddress(Module: THandle; ProcName: PChar): TFarProc
 //освобождает память, занитую dll
 function FreeLibrary(LibModule: THandle);
 

Самое сложное в построений плугинов, это не реализация всего кода, а придусмотрение всего, для чего в программе могут они понадобиться! То есть придусмотреть все возможные типы плугинов! А это не так просто.

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

Исходный текст модуля программы:


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, Menus, Grids, DBGrids;
 
 type
   TForm1 = class(TForm)
     MainMenu1: TMainMenu;
     //меню, которое будет содержать ссылки на плугины
     N1231: TMenuItem;
     procedure FormCreate(Sender: TObject);
   private
     { Private declarations }
     //лист, в котором мы будем держать имена файлов плугинов
     PlugList : TStringList;
     //Процедура загрузки плугина
     procedure LoadPlug(fileName : string);
     //Процедура инициализации и выполнения плугина
     procedure PlugClick(sender : TObject);
   public
     { Public declarations }
 end;
 
 var
 Form1: TForm1;
 
 implementation
 {$R *.DFM}
 

Процедура загрузки плугина. Здесь мы загружаем, вносим имя dll в список и создаём для него пункт меню; загружаем из dll картинку для пункта меню


 procedure TForm1.LoadPlug(fileName: string);
 var
   //Объявление функции, которая будет возвращать имя плугина
   PlugName : function : PChar;
   //Новый пункт меню
   item : TMenuItem;
   //Хендл dll
   handle : THandle;
   //Объект, с помощью которого мы загрузим картинку из dll
   res :TResourceStream;
 begin
   item := TMenuItem.create(mainMenu1); //Создаём новый пункт меню
   handle := LoadLibrary(Pchar(FileName)); //загружаем dll
   if handle <> 0 then //Если удачно, то идём дальше...
   begin
     @PlugName := GetProcAddress(handle,'PluginName'); //грузим процедуру
     if @PlugName <> nil then
       item.caption := PlugName
       //Если всё прошло, идём дальше...
     else
     begin
       ShowMessage('dll not identifi '); //Иначе, выдаём сообщение об ошибке
       Exit; //Обрываем процедуру
     end;
     PlugList.Add(FileName); //Добавляем название dll
     res:= TResourceStream.Create(handle,'bitmap',rt_rcdata); //Загружаем ресурс из dll
     res.saveToFile('temp.bmp'); res.free; //Сохраняем в файл
     item.Bitmap.LoadFromFile('Temp.bmp'); //Загружаем в пункт меню
     FreeLibrary(handle); //Уничтожаем dll
     item.onClick:=PlugClick; //Даём ссылку на обработчик
     Mainmenu1.items[0].add(item); //Добавляем пункт меню
   end;
 end;
 

Процедура выполнения плугина. Здесь мы загружаем, узнаём тип и выполняем


 procedure TForm1.PlugClick(sender: TObject);
 var
   //Объявление функции, которая будет выполнять плугин
   PlugExec : function(AObject : TObject): boolean;
   //Объявление функции, которая будет возвращать тип плугина
   PlugType : function: PChar;
   //Имя dll
   FileName : string;
   //Хендл dll
   handle : Thandle;
 begin
   with (sender as TmenuItem) do
     filename:= plugList.Strings[MenuIndex];
   //Получаем имя dll
   handle := LoadLibrary(Pchar(FileName)); //Загружаем dll
   //Если всё в порядке, то идём дальше
   if handle <> 0 then
   begin
     //Загружаем функции
     @plugExec := GetProcAddress(handle,'PluginExec');
     @plugType := GetProcAddress(handle,'PluginType');
     //А теперь, в зависимости от типа, передаём нужный ей параметр...
     if PlugType = 'FORM' then
       PlugExec(Form1)
     else
     //Если плугин для формы, то передаём форму
     if PlugType = 'CANVAS' then
       PlugExec(Canvas)
     else
     //Если плугин для канвы, то передаём канву
     if PlugType = 'MENU' then
       PlugExec(MainMenu1)
     else
     //Если плугин для меню, то передаём меню
     if PlugType = 'BRUSH' then
       PlugExec(Canvas.brush)
     else
     //Если плугин для заливки, то передаём заливку
     if PlugType = 'NIL' then
       PlugExec(nil);
     //Если плугину ни чего не нужно, то ни чего не передаём
   end;
   FreeLibrary(handle); //Уничтожаем dll
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   SearchRec : TSearchRec; //Запись для поиска
 begin
   plugList:=TStringList.create; //Создаём запись для имён dll'ок
   //ищем первый файл
   if FindFirst('*.dll',faAnyFile, SearchRec) = 0 then
   begin
     LoadPlug(SearchRec.name); //Загружаем первый найденный файл
     while FindNext(SearchRec) = 0 do
       LoadPlug(SearchRec.name);
     //Загружаем последующий
     FindClose(SearchRec); //Закрываем поиск
   end;
   //Левые параметры
   canvas.Font.pitch := fpFixed;
   canvas.Font.Size := 20;
   canvas.Font.Style:= [fsBold];
 end;
 
 end.
 

Здесь написан простой исходный текст dll, то есть нашего плугина. Он обязательно возвращает название, тип и выполняет свои задачи


 library plug;
 
 uses
   SysUtils, graphics, Classes, windows;
 
 {$R bmp.RES}
 
 function PluginType : Pchar;
 begin
   //Мы указали реакцию на этот тип
   Plugintype := 'CANVAS';
 end;
 
 function PluginName:Pchar;
 begin
   //Вот оно, название плугина. Эта строчка будет в менюшке
   PluginName := 'Canvas painter';
 end;
 

Функция выполнения плугина! Здесь мы рисуем на переданной канве анимационную строку.


 function PluginExec(Canvas:TCanvas):Boolean;
 var
   X : integer;
   I : integer;
   Z : byte;
   S : string;
   color : integer;
   proz : integer;
 begin
   color := 10;
   proz :=0;
   S:= 'hello всем это из плугина ля -- ля';
   for Z:=0 to 200 do
   begin
     proz:=proz+2;
     X:= 0;
     for I:=1 to length(S) do
     begin
       X:=X + 20;
       Canvas.TextOut(X,50,S[i]);
       color := color+X*2+Random(Color);
       canvas.Font.Color := color+X*2;
       canvas.font.color := 10;
       canvas.TextOut(10,100,'execute of '+inttostr(proz div 4) + '%');
       canvas.Font.Color := color+X*2;
       sleep(2);
     end;
   end;
   PluginExec:=True;
 end;
 
 exports
   PluginType, PluginName, PluginExec;
 
 end.
 

Пару советов:

  • Не оставляйте у своих плугинов расширение *.dll, это не катит. А вот сделайте, например *.plu . Просто в исходном тексте плугина напишите {$E plu} Ну и в исходном тексте программы ищите не Dll, а уже plu.
  • Когда вы сдаёте программу, напишите к ней уже готовых несколько плугинов, что бы юзеру было интересно искать новые.
  • Сделайте поддержку обновления через интернет. То есть программа заходит на ваш сервер, узнаёт, есть ли новые плугины или нет, если есть - то она их загружает. Этим вы увеличите спрос своей программы и конечно трафик своего сайта!



Создание PolyPolygon используя массив точек


 procedure TForm1.Button1Click(Sender: TObject);
 var
         ptArray : array[0..9] of TPOINT;
         PtCounts : array[0..1] of integer;
 begin
         PtArray[0] := Point(0, 0);
         PtArray[1] := Point(0, 100);
         PtArray[2] := Point(100, 100);
         PtArray[3] := Point(100, 0);
         PtArray[4] := Point(0, 0);
         PtCounts[0] := 5;
         PtArray[5] := Point(25, 25);
         PtArray[6] := Point(25, 75);
         PtArray[7] := Point(75, 75);
         PtArray[8] := Point(75, 25);
         PtArray[9] := Point(25, 25);
         PtCounts[1] := 5;
         PolyPolygon(Form1.Canvas.Handle,
         PtArray,PtCounts,2);
 end;
 




Как динамически создавать пункты подменю в PopupMenu


 procedure TForm1.PopupMenu2Popup(Sender: TObject);
 var
   mi, msub: TmenuItem;
 begin
   with (Sender as TPopupMenu) do
   begin
     // Удаляем все пункты меню
 
     // while Items.Count > 0 do Items.delete(0);
     // Предыдущий код имел утечку памяти. Коррекция от Andrew Stewart (astewart@Strobes.co.nz)
     while Items.Count > 0 do
       Items[0].Free;
 
     // Создаем обычный пункт "Первый"
     mi := TMenuItem.Create(self);
     with mi do
     begin
       Caption := 'Первый';
       OnClick := MyClick;
     end;
     Items.Insert(0, mi);
 
     // Создаем подменю "Подменю" c двумя пунктами "Подменю1" и
     // "Подменю2"
     mi := TMenuItem.Create(self);
     with mi do
     begin
       Caption := 'Подменю';
       msub := TMenuItem.Create(self);
       with msub do
       begin
         Caption := 'Подменю1';
         OnClick := MyClick;
       end;
       Insert(0, msub);
 
       msub := TMenuItem.Create(self);
       with msub do
       begin
         Caption := 'Подменю2';
         OnClick := MyClick;
       end;
       Insert(1, msub);
     end;
     Items.Insert(1, mi);
   end;
 end;
 
 procedure TForm1.MyClick(Sender: TObject);
 begin
   beep;
 end;
 




Создание редактора свойства

Автор: HTH, Dean (Classic Software)

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

1. Опишите класс редактора свойства:


 type
   TTableNameProperty = class(TStringProperty)
     function GetAttributes: TPropertyAttributes; override;
     procedure GetValues(Proc: TGetStrProc); override;
   end;
 
 implementation
 
 { TTableNameProperty }
 
 function TTableNameProperty.GetAttributes: TPropertyAttributes;
 begin
   Result := [paValueList];
 end;
 
 procedure TTableNameProperty.GetValues(Proc: TGetStrProc);
 var
   TableName: string;
 begin
   { *************************************************
     здесь вы должны добавить свой код, чтобы с помощью
     цикла обойти имена всех таблиц, включенных в список
     *************************************************** }
   for I := 0 to ???? do
   begin
     TableName := ????[I];
     Proc(TableName);
   end;
 end;
 

2. Затем вам необходимо зарегистрировать данный редактор свойства следующим образом (в вашей процедуре Register):


 RegisterPropertyEditor(TypeInfo(string), TcsNotebook, 'TableName', TTableNameProperty);
 




Как создать регион (HRNG) по маске

Ниже приведена функция, которая создаёт HRGN из чёрно-белого битмапа. Все чёрные пиксели становятся регионом, а белые становятся прозрачными. Так же не составит труда сделать преобразования для поддержки всех цветов и чтобы один из них был прозрачным.

По окончании необходимо освободить регион при помощи функции DeleteObject.


 function BitmapToRgn(Image: TBitmap): HRGN;
 var
   TmpRgn: HRGN;
   x, y: integer;
   ConsecutivePixels: integer;
   CurrentPixel: TColor;
   CreatedRgns: integer;
   CurrentColor: TColor;
 begin
   CreatedRgns := 0;
   Result := CreateRectRgn(0, 0, Image.Width, Image.Height);
   inc(CreatedRgns);
 
   if (Image.Width = 0) or (Image.Height = 0) then
     exit;
 
   for y := 0 to Image.Height - 1 do
   begin
     CurrentColor := Image.Canvas.Pixels[0,y];
     ConsecutivePixels := 1;
     for x := 0 to Image.Width - 1 do
     begin
       CurrentPixel := Image.Canvas.Pixels[x,y];
 
       if CurrentColor = CurrentPixel then
         inc(ConsecutivePixels)
       else
       begin
         // Входим в новую зону
         if CurrentColor = clWhite then
         begin
           TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1);
           CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
           inc(CreatedRgns);
           DeleteObject(TmpRgn);
         end;
         CurrentColor := CurrentPixel;
         ConsecutivePixels := 1;
       end;
     end;
 
     if (CurrentColor = clWhite) and (ConsecutivePixels > 0) then
     begin
       TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1);
       CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
       inc(CreatedRgns);
       DeleteObject(TmpRgn);
     end;
   end;
 end;
 




Создание RES-файла с помощью BRCC.EXE

Автор: Bob Villiers

Данный метод обходит проблемы, связанные с Image Editor.

В каталоге \DELPHI\BIN имеется утилита коммандной строки, названная BRCC.EXE, позволяющая создавать из файлов, содержащих изображения/иконки, RES-файлы, в обход Image Editor. (Тем не менее, Image Editor хорошо работает при создании или редактировании файлов с изображениями или курсорами. Проблемой был импорт.)

Resource File Compiler описан в справке Windows API help в главе Windows Tools (где вы также можете прочесть о RC.EXE как о BRCC.EXE!). Это сэкономит вам какое-то время!

Сначала, используя Блокнот, создайте файл определения ресурса (Resource Definition) (текстовый) с именем, скажем, MYRES.RC (с обязательным расширением RC). Разместите, каждую на отдельной строке, ссылки на изображения, иконки, и т.п., которые вы хотели бы включить в RES-файл, например:

BITMAP1 BITMAP  <путь><имя файла>
 BITMAP2 BITMAP  <путь><имя файла>
 CURSOR1 CURSOR  <путь><имя файла>
 ICON1   ICON    <путь><имя файла>
Затем (это не обязательно, но сохранит массу времени, особенно если вы экспериментируете), в том же каталоге создайте BAT-Файл, вызывающий программу для компиляции каждого ресурса:
"C:\DELPHI\BIN\BRCC/R %1"
Назовите его, скажем, MAKERES.BAT.

Перейдите в DOS и в каталоге проекта введите "MAKERES MYRES.RC". Заданные ресурсы будут скомпилированы в новый файл MYRES.RES, который может быть прилинкован к вашему проекту как и прежде. Используйте Image Editor для проверки и редактирования.




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

Автор: Nomadic

Смотрите книгу "Developing Custom Delphi Components" от Рэя Конопки.

Здесь немного исправленный пример из этой книги -


 function TMyClass.CreateCalcField(const AFieldName: string;
   AFieldClass: TFieldClass; ASize: Word): TField;
 begin
   Result := FDataSet.FindField(AFieldName); // Field may already exists!
   if Result <> nil then
     Exit;
   if AFieldClass = nil then
   begin
     DBErrorFmt(SUnknownFieldType, [AFieldName]);
   end;
   Result := FieldClass.Create(Owner);
   with Result do
   try
     FieldName := AFieldName;
     if (Result is TStringField) or (Result is TBCDField) or
       (Result is TBlobField) or (Result is TBytesField) or
       (Result is TVarBytesField) then
     begin
       Size := ASize;
     end;
     Calculated := True;
     DataSet := FDataset;
     Name := FDataSet.Name + AFieldName;
   except
     Free; // We must release allocated memory on error!
     raise;
   end;
 end;
 




Создание индекса во время выполнения программы

Автор: OAmiry (Borland)

Ниже приведен код обработчика кнопки OnClick, с помощью которого строится индекс:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   bActive, bExclusive: Boolean;
 begin
   bActive := Table1.Active;
   bExclusive := Table1.Exclusive;
   Table1.IndexDefs.Update;
   with Table1 do
   begin
     Close;
     {таблица dBASE должна быть открыта в монопольном (exclusive) режиме}
     Exclusive := TRUE;
     Open;
     if Table1.IndexDefs.IndexOf('FNAME') <> 0 then
       Table1.AddIndex('FNAME', 'FNAME', []);
     Close;
     Exclusive := bExclusive;
     Active := bActive;
   end;
 end;
 

Если вы собираетесь запускать проект из Delphi, пожалуйста убедитесь в том, что свойство таблицы Active в режиме проектирования установлено в False.




Создание таблицы по образу и подобию

Создайте во время выполнения программы пустую таблицу, скопируйте структуру существующей, включая первичный индекс. На практике это выглядит примерно так:


 var
   Table2  : TTable;
 begin
   Table1.FieldDefs.Update;
   Table1.IndexDefs.Update;
   Table2 := TTable.Create(nil);
   Table2.DatabaseName := Table1.DatabaseName;
   Table2.TableName := 'MyTable';
   Table2.TableType := Table1.TableType;
   Table2.FieldDefs.Assign(Table1.FieldDefs);
   Table2.IndexDefs.Assign(Table1.IndexDefs);
   Table2.CreateTable ;
 end;
 

...один способ сделать это.




Создаём Screen Saver

Хранитель экрана (ScreenSaver) в Windows – это программа, размещенная в каталоге Windows или Windows\System. Расширение эта программа должна иметь scr. При запуске ScreenSaver должен реагировать на параметры. Если первый параметр – "/p", нужно создать окно предварительного просмотра. Если первый параметр – "/s", нужно запустить сам ScreenSaver. В ином случае нужно показать окно настроек хранителя экрана.

Для предварительного просмотра Windows создает окно, на месте которого ScreenSaver должен что-то рисовать. Чтобы отслеживать сообщения о перерисовке окна Preview, а также о его перемещении и закрытии, нужно создать дочернее окно в том же месте и такого же размера. Для этого нужно использовать WinAPI. Цикл, в котором обрабатываются сообщения, удобно сделать через PeekMessage, поскольку в этом случае можно создать событие OnIdle. В нем нужно рисовать что-то в окне предварительного просмотра.

Окно самого ScreenSaver-а можно делать без WinAPI. Для реагирования на события мыши и клавиатуры лучше всего использовать событие OnMessage. Чтобы ScreenSaver работал в фоновом режиме рисовать нужно в обработчике события OnIdle. Причем каждый раз нужно выполнять быструю операцию. Поскольку в окне ScreenSaver-а и в окне предварительного просмотра должно рисоваться одно и то же, удобно сделать единую процедуру, которая бы выполняла короткое действие. В качестве параметров ей нужно сообщать Canvas, высоту и ширину.

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

В первом модуле находится окно хранителя экрана:


 public
   procedure OnMessage(var Msg: TMsg; var Handled: Boolean);
   procedure OnIdle(Sender: TObject; var Done: Boolean);
 end;
 
 var
   Form1: TForm1;
   r, g, b: integer;
   po: TPoint;
   IniFileName: string;
 
 procedure Draw(Canvas: TCanvas; var r, g, b: integer;
 width, height: integer);
 
 implementation
 {$R *.DFM}
 
 uses
   IniFiles;
 
 procedure Draw(Canvas: TCanvas; var r, g, b: integer;
 width, height: integer);
 begin
   with Canvas do
   begin
     r := r + random(3) - 1;
     if r < 0 then
       r := 0;
     if r > 255 then
       r := 255;
     g := g + random(3) - 1;
     if g < 0 then
       g := 0;
     if g > 255 then
       g := 255;
     b := b + random(3) - 1;
     if b < 0 then
       b := 0;
     if b > 255 then
       b := 255;
 
     Pen.Color := RGB(r, g, b);
     LineTo(random(width), random(height));
   end;
 end;
 
 procedure TForm1.OnMessage(var Msg: TMsg; var Handled: Boolean);
 begin
   case Msg.message of
     WM_KEYDOWN, WM_KEYUP,
     WM_SYSKEYDOWN, WM_SYSKEYUP,
     WM_LBUTTONDOWN, WM_RBUTTONDOWN,
     WM_MBUTTONDOWN: Close;
     WM_MOUSEMOVE:
     begin
       if (msg.pt.x <> po.x) or (msg.pt.y <> po.y) then
         Close;
     end;
   end;
 end;
 
 procedure TForm1.OnIdle(Sender: TObject; var Done: Boolean);
 begin
   Draw(Canvas, r, g, b, Width, Height);
   Done := false;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   ini: TIniFile;
 begin
   Application.OnMessage := OnMessage;
   Application.OnIdle := OnIdle;
 
   {Эти два свойства можно установить при помощи Object Inspector}
   BorderStyle := bsNone;
   WindowState := wsMaximized;
 
   ShowCursor(false);
   GetCursorPos(po);
 
   ini := TIniFile.Create(IniFileName);
   if ini.ReadBool('settings', 'clear', true) then
     Brush.Color := clBlack
   else
     Brush.Style := bsClear;
   ini.Destroy;
 end;
 

Окно настроек:


 {$R *.DFM}
 
 uses
   IniFiles, Unit1;
 
 procedure TForm2.FormCreate(Sender: TObject);
 var
   buf: array [0..127] of char;
   ini: TIniFile;
 begin
   GetWindowsDirectory(buf, sizeof(buf));
   if pos(UpperCase(buf), UpperCase(ExtractFilePath(ParamStr(0)))) <= 0 then
     if not CopyFile(PChar(ParamStr(0)), PChar(buf + '\MyScrSaver.scr'), false) then
       ShowMessage('Can not copy the file');
   ini := TIniFile.Create(IniFileName);
   CheckBox1.Checked := ini.ReadBool('settings', 'clear', true);
   ini.Destroy;
 
   {Эти три свойства можно установить при помощи Object Inspector}
   Button1.Caption := 'OK';
   Button2.Caption := 'Cancel';
   CheckBox1.Caption := 'Clear screen';
 end;
 
 procedure TForm2.Button1Click(Sender: TObject);
 var
   ini: TIniFile;
 begin
   ini := TIniFile.Create(IniFileName);
   ini.WriteBool('settings', 'clear', CheckBox1.Checked);
   ini.Destroy;
   Close;
 end;
 
 procedure TForm2.Button2Click(Sender: TObject);
 begin
   Close;
 end;
 

Файл с самой программой (dpr). Чтобы открыть его выберите Project | View Source.


 program Project1;
 
 uses
   Forms, Graphics, Windows, Messages,
   Unit1 in 'Unit1.pas' {Form1},
   Unit2 in 'Unit2.pas' {Form2};
 
 var
   PrevWnd: hWnd;
   rect: TRect;
   can: TCanvas;
 
 procedure Paint;
 begin
   Draw(can, r, g, b, rect.Right - rect.Left, rect.Bottom - rect.Top);
 end;
 
 function MyWndProc(wnd: hWnd; msg: integer;
 wParam, lParam: longint): integer; stdcall;
 begin
   case Msg of
     WM_DESTROY:
     begin
       PostQuitMessage(0);
       result := 0;
     end;
     WM_PAINT:
     begin
       paint;
       result := DefWindowProc(Wnd, Msg, wParam, lParam);
     end;
     else
       result := DefWindowProc(Wnd, Msg, wParam, lParam);
   end;
 end;
 
 procedure Preview;
 const
   ClassName = 'MyScreenSaverClass'#0;
 var
   parent: hWnd;
   WndClass: TWndClass;
   msg: TMsg;
   code: integer;
 begin
   val(ParamStr(2), parent, code);
   if (code <> 0) or (parent <= 0) then
     Exit;
 
   with WndClass do
   begin
     style := CS_PARENTDC;
     lpfnWndProc := addr(MyWndProc);
     cbClsExtra := 0;
     cbWndExtra := 0;
     hIcon := 0;
     hCursor := 0;
     hbrBackground := 0;
     lpszMenuName := nil;
     lpszClassName := ClassName;
   end;
   WndClass.hInstance := hInstance;
   Windows.RegisterClass(WndClass);
 
   GetWindowRect(Parent, rect);
   PrevWnd := CreateWindow(ClassName, 'MyScreenSaver',
   WS_CHILDWINDOW or WS_VISIBLE or WS_BORDER, 0, 0, rect.Right - rect.Left,
   rect.Bottom - rect.Top, Parent, 0, hInstance, nil);
   can := TCanvas.Create;
   can.Handle := GetDC(PrevWnd);
   can.Brush.Color := clBlack;
   can.FillRect(rect);
   repeat
     if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
     begin
       if Msg.message = WM_QUIT then
         break;
       TranslateMessage(Msg);
       DispatchMessage(Msg);
     end
     else
       Paint;
   until
     false;
   ReleaseDC(PrevWnd, can.Handle);
   can.Destroy;
 end;
 
 var
   c: char;
   buf: array [0..127] of char;
 
 begin
   GetWindowsDirectory(buf, sizeof(buf));
   IniFileName := buf + '\myinifile.ini';
   if (ParamCount >= 1) and (Length(ParamStr(1)) > 1) then
     c := UpCase(ParamStr(1)[2])
   else
     c := #0;
   case c of
     'P': Preview;
     'S':
     begin
       Application.Initialize;
       Application.CreateForm(TForm1, Form1);
       Application.Run;
     end;
     else
     begin
       Application.Initialize;
       Application.CreateForm(TForm2, Form2);
       Application.Run;
     end;
   end;
 end.
 




Создание заставки

Перед появлением главного окна во всех серьёзных приложениях сначала появляется заставка. Теперь и у Вас есть возможность повыёживаться! Для создания заставки выполняем следующую последовательность действий:

Начинаем создание нового приложение командой “New Application” (“Новое приложение”) из меню “File” (“Файл”)

Добавьте ещё одну форму: “New Form”(“Новая форма”) из меню “File” (“Файл”). Это окно и будет заставкой. У него нужно убрать рамку с полосой заголовка, установив свойство “BorderStyle” в “bsNone”. Теперь можно смело разработать дизайн окна заставки.

Из меню “Project” (“Проект”) выбрать команду “Options”(“Опции”). Зайти на закладку “Forms”(“Формы”) и Form2 из списка автоматически создаваемых форм (Auto-Create forms) перенести в список доступных форм (Available forms)

На форму-заставку с закладки System вынести компонент Timer. В его свойстве Interval установить значение 5000, а в событии OnTimer написать:


 Timer1.Enabled := false;
 

Это сделано для того, чтобы заставка была видна в период указанного времени – 5000 миллисекунд, т.е. 5 секунд.

Перейти в файл проекта, нажав Ctrl+F12 и выбрав Project1. Исходный код должен выглядеть так:


 program Project1;
 
 uses
   Forms,
   Unit1 in 'Unit1.pas' {Form1},
   Unit2 in 'Unit2.pas' {Form2};
 
 {$R *.RES}
 
 begin
   Application.Initialize;
   Application.CreateForm(TForm1, Form1);
   Application.Run;
 end.
 

Теперь мы внесём сюда немного изменений и код должен стать таким:


 program Project1;
 
 uses
   Forms,
   Unit1 in 'Unit1.pas' {Form1},
   Unit2 in 'Unit2.pas' {Form2};
 
 {$R *.RES}
 
 begin
   Application.Initialize;
   Form2 := TForm2.Create(Application);
   Form2.Show;
   Form2.Update;
   while Form2.Timer1.Enabled do
     Application.ProcessMessages;
   Application.CreateForm(TForm1, Form1);
   Form2.Hide;
   Form2.Free;
   Application.Run;
 end.
 




Конструирование Splitter

У меня есть форма с расположенными на ней компонентами TreeView и Memo. Значение свойства align обоих компонентов позволяет им занимать всю форму. Я хотел бы расположить между ними движок типа Splitter, пропорционально меняющий их размеры (один шире, другой меньше и наоборот), но к сожалению я обладаю лишь дистрибутивом Delphi2 (Splitter вошел в палитру только в Delphi3). Какой компонент мог бы с'имитировать поведение Splitter и как это реализовать?

Предположим, Ваш TreeView расположен в левой, а Memo в правой части формы. Вам нужно сделать следующее:

  • Установите свойство Align компонента TreeView на alLeft.
  • Вырежьте (Ctrl-X) компонент TMemo из вашей формы.
  • Добавьте компонент Panel и присвойте его свойству Align значение alClient.
  • Внутри панели разместите другой компонент Panel.
  • Установите его ширину, равной 8 пикселам, свойству Align присвойте значение alLeft.
  • Скопируйте вырезанный компонент TMemo в панель Panel1 и присвойте свойству Align значение alClient.

Panel2 - движок: теперь вам необходимо добавить процедуры, приведенные ниже. Ваш код будет выглядеть приблизительно так:


 type
 
   TForm1 = class(TForm)
     TreeView1: TTreeview;
     Panel1: TPanel;
     Panel2: TPanel;
     Memo1: TMemo;
     procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer);
     procedure Panel1MouseUp(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer);
     procedure Panel1MouseMove(Sender: TObject; Shift: TShiftState;
       X, Y: Integer);
   private
     Resizing: Boolean;
   public
     ...
   end;
 
 procedure TForm1.Panel2MouseDown(Sender: TObject; Button:
 
   TMouseButton; Shift: TShiftState; X, Y: Integer);
 begin
 
   Resizing := true;
 end;
 
 procedure TForm1.Panel2MouseUp(Sender: TObject; Button: TMouseButton;
 
   Shift: TShiftState; X, Y: Integer);
 begin
 
   Resizing := false;
 end;
 
 procedure TForm1.Panel2MouseMove(Sender: TObject; Shift: TShiftState;
 
   X, Y: Integer);
 begin
 
   if Resizing then
   begin
     TreeView1.Width := TreeView1.Width + X;
     // Предохранение от странных ошибок перерисовки при изменении размеров:
     Panel1.Invalidate;
   end;
 end;
 

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




Написание хранителя экрана

1.В файл проекта {*.DPR} добавить строку {$D SCRNSAVE <название хранителя>} после строки подключения модулей (Uses...).

2.У окна формы убрать системное меню, кнопки и придать свойству WindowState значение wsMaximize.

3.Предусмотреть выход из хранителя при нажатии на клавиши клавиатуры, мыши и при перемещении курсора мыши.

4.Проверить параметры с которым был вызван хранитель и если это /c - показать окно настройки хранителя, а иначе (можно проверять на /s, а можно и не проверять) сам хранитель. /p - для отображения в окне установок хранителя экрана.

5.Скомпилировать хранитель экрана.

6.Переименовать *.EXE файл в файл *.SCR и скопировать его в каталог WINDOWS\SYSTEM.

7.Установить новый хранитель в настройках системы!

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

Все параметры и настройки храните в файле .INI, так как хранитель и окно настройки не связаны друг с другом напрямую. Старайтесь сделать свой хранитель как можно меньше и быстрее. Иначе ваши долго работающие (в фоновом режиме) приложения будут работать еше дольше!

--- в файле *.DPR ---


 {$D SCRNSAVE Пример хранителя экрана}
 
 //проверить переданные параметры}
 IF (ParamStr(1) = '/c') OR (ParamStr(1) = '/C') THEN
  // скрыть курсор мыши
  ShowCursor(False);
  // восстановить курсор мыши
  ShowCursor(True);
 

Более подробно о создании хранителя экрана "по всем правилам" Screen Saver in Win95

Главное о чем стоит упомянуть это, что ваш хранитель экрана будет работать в фоновом режиме и он не должен мешать работе других запущенных программ. Поэтому сам хранитель должен быть как можно меньшего объема. Для уменьшения объема файла в описанной ниже программе не используется визуальные компоненты Delphi, включение хотя бы одного из них приведет к увеличению размера файла свыше 200кб, а так, описанная ниже программа, имеет размер всего 20кб!!! Технически, хранитель экрана является нормальным EXE файлом (с расширением .SCR), который управляется через командные параметры строки. Например, если пользователь хочет изменить параметры вашего хранителя, Windows выполняет его с параметром "-c" в командной строке. Поэтому начать создание вашего хранителя экрана следует с создания примерно следующей функции:


 Procedure RunScreenSaver;
 Var S : String;
 Begin
   S := ParamStr(1);
   If (Length(S) > 1) Then Begin
     Delete(S,1,1); { delete first char - usally "/" or "-" }
     S[1] := UpCase(S[1]);
   End;
   LoadSettings; { load settings from registry }
   If (S = 'C') Then RunSettings
   Else If (S = 'P') Then RunPreview
   Else If (S = 'A') Then RunSetPassword
   Else RunFullScreen;
 End;
 

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


 Procedure RunFullScreen;
 Var
   R          : TRect;
   Msg        : TMsg;
   Dummy      : Integer;
   Foreground : hWnd;
 Begin
   IsPreview := False;  MoveCounter := 3;
   Foreground := GetForegroundWindow;
   While (ShowCursor(False) > 0) do ;
   GetWindowRect(GetDesktopWindow,R);
   CreateScreenSaverWindow(R.Right-R.Left,R.Bottom-R.Top,0);
   CreateThread(nil,0,@PreviewThreadProc,nil,0,Dummy);
   SystemParametersInfo(spi_ScreenSaverRunning,1,@Dummy,0);
   While GetMessage(Msg,0,0,0) do Begin
     TranslateMessage(Msg);
     DispatchMessage(Msg);
   End;
   SystemParametersInfo(spi_ScreenSaverRunning,0,@Dummy,0);
   ShowCursor(True);
   SetForegroundWindow(Foreground);
 End;
 

Во-первых, мы проинициализировали некоторые глобальные переменные (описанные далее), затем прячем курсор мыши и создаем окно хранителя экрана. Имейте в виду, что важно уведомлять Windows, что это - хранителя экрана через SystemParametersInfo (это выводит из строя Ctrl-Alt-Del чтобы нельзя было вернуться в Windows не введя пароль). Создание окна хранителя:


 Function CreateScreenSaverWindow(Width,Height : Integer;
   ParentWindow : hWnd) : hWnd;
 Var WC : TWndClass;
 Begin
   With WC do Begin
     Style := cs_ParentDC;
     lpfnWndProc := @PreviewWndProc;
     cbClsExtra := 0;  cbWndExtra := 0; hIcon := 0; hCursor := 0;
     hbrBackground := 0; lpszMenuName := nil;
     lpszClassName := 'MyDelphiScreenSaverClass';
     hInstance := System.hInstance;
   end;
   RegisterClass(WC);
   If (ParentWindow  0) Then
     Result := CreateWindow('MyDelphiScreenSaverClass','MySaver',
       ws_Child Or ws_Visible or ws_Disabled,0,0,
       Width,Height,ParentWindow,0,hInstance,nil)
   Else Begin
     Result := CreateWindow('MyDelphiScreenSaverClass','MySaver',
       ws_Visible or ws_Popup,0,0,Width,Height, 0,0,hInstance,nil);
     SetWindowPos(Result,hwnd_TopMost,0,0,0,0,swp_NoMove or swp_NoSize or
 swp_NoRedraw);
   End;
   PreviewWindow := Result;
 End;
 

Теперь окна созданы используя вызовы API. Я удалил проверку ошибки, но обычно все проходит хорошо, особенно в этом типе приложения. Теперь Вы можете погадать, как мы получим handle родительского окна предварительного просмотра ? В действительности, это совсем просто: Windows просто передает handle в командной строке, когда это нужно. Таким образом:


 Procedure RunPreview;
 Var
   R             : TRect;
   PreviewWindow : hWnd;
   Msg           : TMsg;
   Dummy         : Integer;
 Begin
   IsPreview := True;
   PreviewWindow := StrToInt(ParamStr(2));
   GetWindowRect(PreviewWindow,R);
   CreateScreenSaverWindow(R.Right-R.Left,R.Bottom-R.Top,PreviewWindow);
   CreateThread(nil,0,@PreviewThreadProc,nil,0,Dummy);
   While GetMessage(Msg,0,0,0) do Begin
     TranslateMessage(Msg); DispatchMessage(Msg);
   End;
 End;
 

Как Вы видите, window handle является вторым параметром (после "-p"). Чтобы "выполнять" хранителя экрана - нам нужна нить. Это создается с вышеуказанным CreateThread. Процедура нити выглядит примерно так:


 Function PreviewThreadProc(Data : Integer) : Integer; StdCall;
 Var R : TRect;
 Begin
   Result := 0; Randomize;
   GetWindowRect(PreviewWindow,R);
   MaxX := R.Right-R.Left;  MaxY := R.Bottom-R.Top;
   ShowWindow(PreviewWindow,sw_Show); UpdateWindow(PreviewWindow);
   Repeat
     InvalidateRect(PreviewWindow,nil,False);
     Sleep(30);
   Until QuitSaver;
   PostMessage(PreviewWindow,wm_Destroy,0,0);
 End;
 

Нить просто заставляет обновляться изображения в нашем окне, спит на некоторое время, и обновляет изображения снова. А Windows будет посылать сообщение WM_PAINT на наше окно (не в нить !). Для того, чтобы оперировать этим сообщением, нам нужна процедура:


 Function PreviewWndProc(Window : hWnd; Msg,WParam,
   LParam : Integer): Integer; StdCall;
 Begin
   Result := 0;
   Case Msg of
     wm_NCCreate  : Result := 1;
     wm_Destroy   : PostQuitMessage(0);
     wm_Paint     : DrawSingleBox; { paint something }
     wm_KeyDown   : QuitSaver := AskPassword;
     wm_LButtonDown, wm_MButtonDown, wm_RButtonDown, wm_MouseMove :
                    Begin
                      If (Not IsPreview) Then Begin
                        Dec(MoveCounter);
                        If (MoveCounter <= 0) Then QuitSaver := AskPassword;
                      End;
                    End;
      Else Result := DefWindowProc(Window,Msg,WParam,LParam);
   End;
 End;
 

Если мышь перемещается, кнопка нажала, мы спрашиваем у пользователя пароль:


 Function AskPassword : Boolean;
 Var
   Key   : hKey;
   D1,D2 : Integer; { two dummies }
   Value : Integer;
   Lib   : THandle;
   F     : TVSSPFunc;
 Begin
   Result := True;
   If (RegOpenKeyEx(hKey_Current_User,'Control Panel\Desktop',0,
       Key_Read,Key) = Error_Success) Then
   Begin
     D2 := SizeOf(Value);
     If (RegQueryValueEx(Key,'ScreenSaveUsePassword',nil,@D1,
         @Value,@D2) = Error_Success) Then
     Begin
       If (Value  0) Then Begin
         Lib := LoadLibrary('PASSWORD.CPL');
         If (Lib > 32) Then Begin
           @F := GetProcAddress(Lib,'VerifyScreenSavePwd');
           ShowCursor(True);
           If (@F  nil) Then Result := F(PreviewWindow);
           ShowCursor(False);
           MoveCounter := 3; { reset again if password was wrong }
           FreeLibrary(Lib);
         End;
       End;
     End;
     RegCloseKey(Key);
   End;
 End;
 

Это также демонстрирует использование registry на уровне API. Также имейте в виду как мы динамически загружаем функции пароля, используюя LoadLibrary. Запомните тип функции? TVSSFunc ОПРЕДЕЛЕН как:


 Type
 TVSSPFunc = Function(Parent : hWnd) : Bool; StdCall;
 
 // Теперь почти все готово, кроме диалога конфигурации. Это запросто:
 
 Procedure RunSettings;
 Var Result : Integer;
 Begin
   Result := DialogBox(hInstance,'SaverSettingsDlg',0,@SettingsDlgProc);
   If (Result = idOK) Then SaveSettings;
 End;
 
 

Трудная часть -это создать диалоговый сценарий (запомните: мы не используем здесь Delphi формы!). Я сделал это, используя 16-битовую Resource Workshop (остался еще от Turbo Pascal для Windows). Я сохранил файл как сценарий (текст), и скомпилированный это с BRCC32:


 SaverSettingsDlg DIALOG 70, 130, 166, 75
 STYLE WS_POPUP | WS_DLGFRAME | WS_SYSMENU
 CAPTION "Settings for Boxes"
 FONT 8, "MS Sans Serif"
 BEGIN
     DEFPUSHBUTTON "OK", 5, 115, 6, 46, 16
     PUSHBUTTON "Cancel", 6, 115, 28, 46, 16
     CTEXT "Box &Color:", 3, 2, 30, 39, 9
     COMBOBOX 4, 4, 40, 104, 50, CBS_DROPDOWNLIST | CBS_HASSTRINGS
     CTEXT "Box &Type:", 1, 4, 3, 36, 9
     COMBOBOX 2, 5, 12, 103, 50, CBS_DROPDOWNLIST | CBS_HASSTRINGS
     LTEXT "Boxes Screen Saver for Win32 Copyright (c) 1996 Jani
            Jдrvinen.", 7, 4, 57, 103, 16,
            WS_CHILD | WS_VISIBLE | WS_GROUP
 END
 
 

Почти также легко сделать диалоговое меню:


 Function SettingsDlgProc(Window : hWnd; Msg,WParam,LParam : Integer):
 Integer; StdCall;
 Var S : String;
 Begin
   Result := 0;
   Case Msg of
     wm_InitDialog : Begin
                       { initialize the dialog box }
                       Result := 0;
                     End;
     wm_Command    : Begin
                       If (LoWord(WParam) = 5) Then EndDialog(Window,idOK)
                       Else If (LoWord(WParam) = 6) Then EndDialog(Window,idCancel);
                     End;
     wm_Close      : DestroyWindow(Window);
     wm_Destroy    : PostQuitMessage(0);
     Else Result := 0;
   End;
 End;
 

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


 Procedure SaveSettings;
 Var
   Key   : hKey;
   Dummy : Integer;
 Begin
   If (RegCreateKeyEx(hKey_Current_User,
                      'Software\SilverStream',
                      0,nil,Reg_Option_Non_Volatile,
                      Key_All_Access,nil,Key,
                      @Dummy) = Error_Success) Then Begin
     RegSetValueEx(Key,'RoundedRectangles',0,Reg_Binary,
      @RoundedRectangles,SizeOf(Boolean));
     RegSetValueEx(Key,'SolidColors',0,Reg_Binary, @SolidColors,SizeOf(Boolean));
     RegCloseKey(Key);
   End;
 End;
 

Загружаем параметры так:


 Procedure LoadSettings;
 Var
   Key   : hKey;
   D1,D2 : Integer; { two dummies }
   Value : Boolean;
 Begin
   If (RegOpenKeyEx(hKey_Current_User,
                    'Software\SilverStream',0,
                    Key_Read,
                    Key) = Error_Success) Then Begin
     D2 := SizeOf(Value);
     If (RegQueryValueEx(Key,'RoundedRectangles',nil,@D1,
         @Value, @D2) = Error_Success) Then
     Begin
       RoundedRectangles := Value;
     End;
     If (RegQueryValueEx(Key,'SolidColors',nil,@D1,
         @Value,@D2) = Error_Success) Then
     Begin
       SolidColors := Value;
     End;
     RegCloseKey(Key);
   End;
 End;
 

Легко? Нам также нужно позволить пользователю, установить пароль. Я честно не знаю почему это оставлено разработчику приложений ? Тем не менее:


 Procedure RunSetPassword;
 Var
   Lib : THandle;
   F   : TPCPAFunc;
 Begin
   Lib := LoadLibrary('MPR.DLL');
   If (Lib > 32) Then Begin
     @F := GetProcAddress(Lib,'PwdChangePasswordA');
     If (@F  nil) Then F('SCRSAVE',StrToInt(ParamStr(2)),0,0);
     FreeLibrary(Lib);
   End;
 End;
 

Мы динамически загружаем (недокументированную) библиотеку MPR.DLL, которая имеет функцию, чтобы установить пароль хранителя экрана, так что нам не нужно беспокоиться об этом. TPCPAFund ОПРЕДЕЛЕН как:


 Type
   TPCPAFunc = Function(A : PChar; Parent : hWnd;
     B,C : Integer) : Integer; StdCall;
 

(Не спрашивайте меня что за параметры B и C) Теперь единственная вещь, которую нам нужно рассмотреть, - самая странная часть: создание графики. Я не великий ГУРУ графики, так что Вы не увидите затеняющие многоугольники, вращающиеся в реальном времени. Я только сделал некоторые ящики.


 Procedure DrawSingleBox;
 Var
   PaintDC  : hDC;
   Info     : TPaintStruct;
   OldBrush : hBrush;
   X,Y      : Integer;
   Color    : LongInt;
 Begin
   PaintDC := BeginPaint(PreviewWindow,Info);
   X := Random(MaxX); Y := Random(MaxY);
   If SolidColors Then
     Color :=
 GetNearestColor(PaintDC,RGB(Random(255),Random(255),Random(255)))
   Else Color := RGB(Random(255),Random(255),Random(255));
   OldBrush := SelectObject(PaintDC,CreateSolidBrush(Color));
   If RoundedRectangles Then
     RoundRect(PaintDC,X,Y,X+Random(MaxX-X),Y+Random(MaxY-Y),20,20)
   Else Rectangle(PaintDC,X,Y,X+Random(MaxX-X),Y+Random(MaxY-Y));
   DeleteObject(SelectObject(PaintDC,OldBrush));
   EndPaint(PreviewWindow,Info);
 End;
 

Чтобы закончить создание хранителя, я даю Вам некоторые детали. Первые, глобальные переменные:


 Var
   IsPreview         : Boolean;
   MoveCounter       : Integer;
   QuitSaver         : Boolean;
   PreviewWindow     : hWnd;
   MaxX,MaxY         : Integer;
   RoundedRectangles : Boolean;
   SolidColors       : Boolean;
 

Затем исходная программа проекта (.dpr). Красива, а!?


 program MySaverIsGreat;
 uses
    windows, messages, Utility; { defines all routines }
 {$R SETTINGS.RES}
 begin
   RunScreenSaver;
 end.
 

Ох, чуть не забыл: Если, Вы используете SysUtils в вашем проекте (StrToInt определен там) Вы получаете большой EXE чем обещанный 20k. Если Вы хотите все же иметь20k, Вы не можете использовать SysUtils так, или Вам нужно написать вашу собственную StrToInt программу.

Конец.

Use Val... ;-)

перевод: Владимиров А.М.

От переводчика. Если все же очень трудно обойтись без использования Delphi-форм, то можно поступить как в случае с вводом пароля: форму изменения параметров хранителя сохранить в виде DLL и инамически ее загружать при необходимости. Т.о. будет маленький и шустрый файл самого хранителя экрана и довеска DLL для конфигурирования и прочего (там объем и скорость уже не критичны).




Создаём SystemDSN при помощи Delphi

Этот пример показывает один из способов создания ODBC драйвера для доступа к файлу Access MDB. Подобная операция применима к большинству файлов баз данных. Естевственно, Вам потребуется MDB файл, для того, чтобы связать его с DSN.


 const
   ODBC_ADD_DSN = 1;        // Добавляем источник данных
   ODBC_CONFIG_DSN = 2;     // Конфигурируем (редактируем) источник данных
   ODBC_REMOVE_DSN = 3;     // Удаляем источник данных
   ODBC_ADD_SYS_DSN = 4;    // Добавляем системный DSN
   ODBC_CONFIG_SYS_DSN = 5; // Конфигурируем системный DSN
   ODBC_REMOVE_SYS_DSN = 6; // удаляем системный DSN
 
 type
   TSQLConfigDataSource = function( hwndParent: HWND; fRequest: WORD;
   lpszDriver: LPCSTR; lpszAttributes: LPCSTR ) : BOOL; stdcall;
 
 procedure Form1.FormCreate(Sender: TObject);
 var
   pFn: TSQLConfigDataSource;
   hLib: LongWord;
   strDriver: string;
   strHome: string;
   strAttr: string;
   strFile: string;
   fResult: BOOL;
   ModName: array[0..MAX_PATH] of Char;
   srInfo : TSearchRec;
 begin
   Windows.GetModuleFileName( HInstance, ModName, SizeOf(ModName) );
   strHome := ModName;
   while ( strHome[length(strHome)] <> '\' ) do
     Delete( strHome, length(strHome), 1 );
   // Тестовая база данных (Axes = Access)
   strFile := strHome + 'TestData.MDB';
   // загружаем библиотеку (путь по умолчанию)
   hLib := LoadLibrary( 'ODBCCP32' );
   if( hLib <> NULL ) then
   begin
     @pFn := GetProcAddress( hLib, 'SQLConfigDataSource' );
     if( @pFn <> nil ) then
     begin
       // начинаем создание DSN
       strDriver := 'Microsoft Access Driver (*.mdb)';
       strAttr := Format( 'DSN=TestDSN' + #0 + 'DBQ=%s' + #0 +
       'Exclusive=1' + #0 + 'Description=Test Data' + #0 + #0, [strFile] );
       fResult := pFn( 0, ODBC_ADD_SYS_DSN, @strDriver[1], @strAttr[1] );
       if( fResult = false ) then
         ShowMessage( 'Ошибка создания DSN (Datasource) !' );
 
       // test/create MDB file associated with DSN
       if( FindFirst( strFile, 0, srInfo ) <> 0 ) then
       begin
         strDriver := 'Microsoft Access Driver (*.mdb)';
         strAttr := Format( 'DSN=TestDSN'+#0+ 'DBQ=%s'+#0+ 'Exclusive=1'+#0+
         'Description=Test Data'+#0+ 'CREATE_DB="%s"'#0+#0, [strFile,strFile] );
         fResult := pFn( 0, ODBC_ADD_SYS_DSN, @strDriver[1], @strAttr[1] );
         if( fResult = false ) then
           ShowMessage( 'Ошибка создания MDB (файла базы данных) !' );
       end;
       FindClose( srInfo );
     end;
     FreeLibrary( hLib );
   end
   else
     ShowMessage( 'Невозможно загрузить ODBCCP32.DLL' );
 end;
 




Создание ярлыков на рабочем столе, старт меню, панели быстрого запуска


 uses
   Registry,
   ActiveX,
   ComObj,
   ShlObj;
 
 type
   ShortcutType = (_DESKTOP, _QUICKLAUNCH, _SENDTO, _STARTMENU, _OTHERFOLDER);
 
 function CreateShortcut(SourceFileName: string; // the file the shortcut points to 
                         Location: ShortcutType; // shortcut location 
                         SubFolder,  // subfolder of location 
                         WorkingDir, // working directory property of the shortcut 
                         Parameters,
                         Description: string): //  description property of the shortcut 
                         string;
 const
   SHELL_FOLDERS_ROOT = 'Software\MicroSoft\Windows\CurrentVersion\Explorer';
   QUICK_LAUNCH_ROOT = 'Software\MicroSoft\Windows\CurrentVersion\GrpConv';
 var
   MyObject: IUnknown;
   MySLink: IShellLink;
   MyPFile: IPersistFile;
   Directory, LinkName: string;
   WFileName: WideString;
   Reg: TRegIniFile;
 begin
 
   MyObject := CreateComObject(CLSID_ShellLink);
   MySLink := MyObject as IShellLink;
   MyPFile := MyObject as IPersistFile;
 
   MySLink.SetPath(PChar(SourceFileName));
   MySLink.SetArguments(PChar(Parameters));
   MySLink.SetDescription(PChar(Description));
 
   LinkName := ChangeFileExt(SourceFileName, '.lnk');
   LinkName := ExtractFileName(LinkName);
 
   // Quicklauch 
   if Location = _QUICKLAUNCH then
   begin
     Reg := TRegIniFile.Create(QUICK_LAUNCH_ROOT);
     try
       Directory := Reg.ReadString('MapGroups', 'Quick Launch', '');
     finally
       Reg.Free;
     end;
   end
   else
   // Other locations 
   begin
     Reg := TRegIniFile.Create(SHELL_FOLDERS_ROOT);
     try
     case Location of
       _OTHERFOLDER : Directory := SubFolder;
       _DESKTOP     : Directory := Reg.ReadString('Shell Folders', 'Desktop', '');
       _STARTMENU   : Directory := Reg.ReadString('Shell Folders', 'Start Menu', '');
       _SENDTO      : Directory := Reg.ReadString('Shell Folders', 'SendTo', '');
     end;
     finally
       Reg.Free;
     end;
   end;
 
   if Directory <> '' then
   begin
     if (SubFolder <> '') and (Location <> _OTHERFOLDER) then
       WFileName := Directory + '\' + SubFolder + '\' + LinkName
     else
       WFileName := Directory + '\' + LinkName;
 
 
     if WorkingDir = '' then
       MySLink.SetWorkingDirectory(PChar(ExtractFilePath(SourceFileName)))
     else
       MySLink.SetWorkingDirectory(PChar(WorkingDir));
 
     MyPFile.Save(PWChar(WFileName), False);
     Result := WFileName;
   end;
 end;
 
 function GetProgramDir: string;
 var
   reg: TRegistry;
 begin
   reg := TRegistry.Create;
   try
     reg.RootKey := HKEY_CURRENT_USER;
     reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', False);
     Result := reg.ReadString('Programs');
     reg.CloseKey;
   finally
     reg.Free;
   end;
 end;
 
 // Some examples: 
 
 procedure TForm1.Button1Click(Sender: TObject);
 const
  PROGR = 'c:\YourProgram.exe';
 var
   resPath: string;
 begin
   //Create a Shortcut in the Quckick launch toolbar 
   CreateShortcut(PROGR, _QUICKLAUNCH, '','','','Description');
 
   //Create a Shortcut on the Desktop 
   CreateShortcut(PROGR, _DESKTOP, '','','','Description');
 
   //Create a Shortcut in the Startmenu /"Programs"-Folder 
   resPath := CreateShortcut(PROGR, _OTHERFOLDER, GetProgramDir,'','','Description');
   if resPath <> '' then
   begin
     ShowMessage('Shortcut Successfully created in: ' + resPath);
   end;
 end;
 




Как создать таблицу базы данных, не используя Database Desktop

Положите компонент TTable на форму и попробуйте указанную ниже процедуру.


 procedure TForm1.CreateMyTable(NameFile: string);
 begin
   with Table1 do
   begin
     Active := False;
     DatabaseName := '';
     TableName := NameFile;
     TableType := ttDefault;
     with FieldDefs do
     begin
       Clear;
       Add('EmpNo', ftInteger, 0, False);
       Add('LastName', ftString, 20, False);
       Add('FirstName', ftString, 15, False);
       Add('PhoneExt', ftString, 4, False);
       Add('HireDate', ftDateTime, 0, False);
       Add('Salary', ftFloat, 0, False);
     end;
     with IndexDefs do
     begin
       Clear;
       Add('', 'EmpNo', [ixPrimary, ixUnique]);
       Add('ByName', 'LastName;FirstName', [ixCaseInsensitive]);
     end;
     CreateTable;
     Free;
   end;
 end;
 




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



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



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


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