Source Code Delphi Samples with Sources

Статус
В этой теме нельзя размещать новые ответы.

emailx45

Местный
Регистрация
5 Май 2008
Сообщения
3,571
Реакции
2,438
Credits
573
Generate Cross Platform Dynamic Forms At Runtime From JSON In Delphi
(tested in 10.2.1 Tokyo, but, can work in another version later)
[SHOWTOGROUPS=4,19,20]
32xFC5U.png


  • The Hospitality Survey Client project is part of the Hospitality Survey App template for Delphi 10.2.1 Tokyo that Embarcadero has released through their GetIt platform. The Hospitality Survey App consists of four different projects.
  • In this blog post I will cover the dynamic form generator that is built into the Hospitality Survey Client project.
  • Also keep in mind that the client can be deployed to Android, iOS, macOS, and Windows with a single code base and a single responsive UI.
  • Basically how it works is on the server there is a database table which contains the list of survey questions to be asked to patrons from each tenant (in this case restaurant). The /survey/ end point in RAD Server is called from TBackendEndpoint (which is basically a TRESTClient) in the Survey App Client.
  • The RAD Server end point returns the contents of the Questions table as the FireDAC JSON format.
  • You can customize the questions using the Hospitality Survey Editor.
  • The Client saves out the FireDAC JSON to a surveys.json file which is then loaded into an TFDMemTable.
  • The GenerateSurvey() function (see below) loops through the records in the TFDMemTable and creates a TFrame for each record.
  • Each record corresponds to a question in the database and you can see the different fields in a record below: ID
    • An ID for the question.name
    • A short name for the question with no spaces.title
    • The text of the question as it will appear in the survey.type
    • The type of question controls which question template is loaded on the client.
  • The existing types are: rating, yes/no, edit, options/options
    • If the type of the question is set to options this field is used to populate the options. It's value is a JSON array of options.value
    • The value is where the user submitted data is stored. It can be left blank but could be used to provide a default answer.category
    • The category of the question. This field is provided for expandability.tenant_id
    • The tenant ID of the question.
  • If the tenant_id field is blank all tenants will get the question.
  • If it is set to a tenant only that tenant will get the question.
  • The Type column determines which TFrame is loaded for that record.
  • The built in types are: rating, yesno, edit, options.
  • You can add your own row types as well by modifying the GenerateSurvey() procedure.
  • You can see the units below for each of the dynamic TFrames including a header frame and a complete button frame for submitting the form.uSurveyHeaderFrame.pas
    • Contains the header for the top of the survey.uRatingBarFrame.pas
    • Contains the star rating track bar survey question type.uYesNoFrame.pas
    • Contains the Yes/No survey question type.uEditFrame.pas
    • Contains the edit survey question type.uComboBoxFrame.pas
    • Contains the combo box survey question type.uCompleteFrame.pas
    • Contains the complete button for the survey.
  • The GenerateSurvey() procedure itself is pretty simple.
  • It loops through the TFDMemTable dataset and checks the type field to see which TFrame to load and populate for that record.
  • The options field is a JSON array that is used to populate the values for the yesno type and options type.
  • The ID field is used to mark the TFrame with the specific question it was created from (FrameItem.Tag := BindSourceDBForm.DataSet.FieldByName('ID').AsInteger
  • So that the value field can be filled out with the answer from the user.
  • Once the survey has been completed by the user then the entire contents of the TFDMemTable are saved out to the FireDAC JSON format and uploaded back to the server via a POST from a TBackendEndpoint component to the /survey/complete endpoint.
  • In the case of the Hospitality Survey App all of the uploaded records are saved for each collected survey.
  • This allows the survey questions to be created, removed, and changed without affecting any of the existing surveys that have already been collected.

Код:
procedure TMainForm.GenerateSurvey(Sender: TObject);
var
  FrameItem: TFrame;
  FieldType: String;
  FieldCategory: Integer;
  JSONArray: TJSONArray;
  I: Integer;
begin
  FrameItem := TSurveyHeaderFrame.Create(TFMXObject(Sender));
  FrameItem.Parent := TFMXObject(Sender);
  FrameItem.Name := 'FSurveyHeader';
  FrameItem.Align := TAlignLayout.Top;
  FrameItem.Position.Y := 0;
  BindSourceDBForm.DataSet.First;
//
  while not BindSourceDBForm.DataSet.Eof do
  begin
    FieldCategory := BindSourceDBForm.DataSet.FieldByName('category').AsInteger;
      FieldType := BindSourceDBForm.DataSet.FieldByName('type').AsString;
//
      if FieldType = 'edit' then
      begin
        FrameItem := TEditFrame.Create(TFMXObject(Sender));
        FrameItem.Parent := TFMXObject(Sender);
        TEditFrame(FrameItem).QuestionText.Text :=
          BindSourceDBForm.DataSet.FieldByName('title').AsString;
      end;
//
      if FieldType = 'yesno' then
      begin
        FrameItem := TYesNoFrame.Create(TFMXObject(Sender));
        FrameItem.Parent := TFMXObject(Sender);
        TYesNoFrame(FrameItem).QuestionText.Text := BindSourceDBForm.DataSet.FieldByName('title').AsString;
        JSONArray := TJSONObject.ParseJSONValue(BindSourceDBForm.DataSet.FieldByName('options').AsString) as TJSONArray;
//
        for I := 0 to JSONArray.Count - 1 do
        begin
          case I of
            0:
              begin
                TYesNoFrame(FrameItem).ValueSpeedButton1.Text := JSONArray.Items.Value;
                TYesNoFrame(FrameItem).ValueSpeedButton1.GroupName := BindSourceDBForm.DataSet.FieldByName('name').AsString;
              end;
            1:
              begin
                TYesNoFrame(FrameItem).ValueSpeedButton2.Text := JSONArray.Items.Value;
                TYesNoFrame(FrameItem).ValueSpeedButton2.GroupName := BindSourceDBForm.DataSet.FieldByName('name').AsString;
              end;
          end;
        end;
//
        JSONArray.Free;
      end;
//
      if FieldType = 'rating' then
      begin
        FrameItem := TRatingBarFrame.Create(TFMXObject(Sender));
        FrameItem.Parent := TFMXObject(Sender);
        TRatingBarFrame(FrameItem).QuestionText.Text := BindSourceDBForm.DataSet.FieldByName('title').AsString;
      end;
//
      if FieldType = 'options' then
      begin
        FrameItem := TOptionsFrame.Create(TFMXObject(Sender));
        FrameItem.Parent := TFMXObject(Sender);
        TOptionsFrame(FrameItem).QuestionText.Text := BindSourceDBForm.DataSet.FieldByName('title').AsString;
        JSONArray := TJSONObject.ParseJSONValue(BindSourceDBForm.DataSet.FieldByName('options').AsString) as TJSONArray;
        TOptionsFrame(FrameItem).ValueComboBox.Items.BeginUpdate;
        for I := 0 to JSONArray.Count - 1 do
        begin
          TOptionsFrame(FrameItem).ValueComboBox.Items.Add(JSONArray.Items.Value);
        end;
//
        TOptionsFrame(FrameItem).ValueComboBox.Items.EndUpdate;
        JSONArray.Free;
      end;
//
      FrameItem.Name := 'F' + BindSourceDBForm.DataSet.FieldByName('ID').AsString;
      FrameItem.Align := TAlignLayout.Top;
      FrameItem.Tag := BindSourceDBForm.DataSet.FieldByName('ID').AsInteger;
      FrameItem.Position.Y := BindSourceDBForm.DataSet.FieldByName('ID').AsInteger * 100;
//
    BindSourceDBForm.DataSet.Next;
//
    Application.ProcessMessages;
  end;
//
  FrameItem := TCompleteFrame.Create(TFMXObject(Sender));
  FrameItem.Parent := TFMXObject(Sender);
  FrameItem.Name := 'FComplete';
  FrameItem.Align := TAlignLayout.Top;
  FrameItem.Position.Y := 1000000;
  TCompleteFrame(FrameItem).CompleteButton.OnClick := CompleteClick;
end;
  • The selected option in each TFrame gets sent back to the TFDMemTable via the UpdateValueByID() procedure as you can see below. In the below code the Self.Tag field corresponds to the ID field of the question.
Код:
procedure TOptionsFrame.ValueComboBoxChange(Sender: TObject);
begin
  MainForm.UpdateValueByID(Self.Tag,ValueComboBox.Items[ValueComboBox.ItemIndex]);
end;
  • The UpdateValueByID(), procedure uses the Locate(), procedure on the DataSet to find the correct record and then update the value field.
Код:
procedure TMainForm.UpdateValueByID(ID: Integer; const Value: string);
begin
  if BindSourceDBForm.DataSet.Locate('ID', VarArrayOf([ID]), []) = True then
  begin
    BindSourceDBForm.DataSet.Edit;
    BindSourceDBForm.DataSet.FieldByName('value').AsString := Value;
    BindSourceDBForm.DataSet.Post;
  end;
end;

tQHpaYC.jpg
[/SHOWTOGROUPS]
 
Последнее редактирование:

emailx45

Местный
Регистрация
5 Май 2008
Сообщения
3,571
Реакции
2,438
Credits
573
Webinar by Marcu Cantu, about High DPI crossing 2 display with distinct resolution
2 display with same app (High res 4K and Low res Windows default) on XE10.3 RIO
 
Последнее редактирование:

emailx45

Местный
Регистрация
5 Май 2008
Сообщения
3,571
Реакции
2,438
Credits
573
Demo how to use Theme like Windiws 10 using style file. Cool!
[SHOWTOGROUPS=4,19,20]
1552101930873.png

1552101944859.png
For VCL application development and appearance, "*.vsf" theme style files can be simply placed in the default "Styles" folder.

1552101955648.png

Hence the apps can be decorated with the dark, or light theme, as if inherited from the RAD Studio Rio IDE theme.

In the main IDE window of the RAD Studio, under the "Custom Styles" in the "Project>Options>Application>Appearance" of the "Project Options" window, select "Win10IDE_Dark" or "Win10IDE_Lite" theme to apply the decoration.

1552101969444.png

Since the style selection, application should appear as it shown in the Style Preview sample.

Thank you.

Best regards.


Для просмотра ссылки Войди или Зарегистрируйся
[/SHOWTOGROUPS]
 
Последнее редактирование:

emailx45

Местный
Регистрация
5 Май 2008
Сообщения
3,571
Реакции
2,438
Credits
573
How to update all library paths programmatically for any component
thanks to Devine (unknow by me)
[SHOWTOGROUPS=4,19,20]
Only 3 functions/procedures are required:
  1. RegRead
  2. RegWrite and
  3. UpdateLibPath
Example for removing redundant/old entries in the library paths in Delphi DX10.3 Rio:


Note:
Adding a path is nothing but appending an entry, seperated by semicolon.

Summary:
There is absolute no need to write an installer/uninstaller for any component.
Tools are always convenient and help saving a lot of time.

Edit:
In the same way and with even less effort all packages of any component pack can be automatically removed from any IDE and added to any IDE.

Skydevil said:
It would be fine, when anytime the handling of packages and the installation in the IDE is simplified as much, that not external tools are needed.


That would be fine, but this kind of ultimate simplification didn't happen in the past and won't happen in the near future. Therefore I started writing a lot of tools in the past to be entirely independent from the features provided inside the IDE.
Код:
uses
Winapi.ShellApi,
System.StrUtils,
System.Win.Registry,
System.Types;
...
...
function IsUserAnAdmin(): BOOL; external shell32;

implementation
...
...

function RegRead(const RootKey: Winapi.Windows.HKEY; pKey, pField: string): string;
var
  Reg: TRegistry;

begin
  Reg := TRegistry.Create;
  Reg.RootKey := RootKey;
  with Reg do
  begin
    if OpenKey(pKey, False) then
        Result := Readstring(pField);
    CloseKey;
  end;
end;

procedure RegWrite(const RootKey: Winapi.Windows.HKEY; pKey, pField, pValue: string);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  Reg.RootKey := RootKey;
  with Reg do
  begin
     if OpenKey(pKey, True) then
         WriteString(pField, pValue) ;
     CloseKey;
  end;
end;

procedure UpdateLibPath(RegKey, RegValue, PathToRemove :String);
var OldValue, NewValue: String;
    PathList: TStringDynArray;
    I, ZZ, Position: Integer;
    isIncluded: Boolean;

begin
   OldValue := RegRead(HKEY_CURRENT_USER, RegKey, RegValue);
   if  OldValue <> '' then
      begin
         PathList := TStringDynArray.Create();
         PathList := SplitString(OldValue,';');
         NewValue := '';
         ZZ := 0;
         isIncluded := False;

         for I := 0 to High(PathList) do
         begin
            Position := POS(PathToRemove,PathList ) ;
            if  Position=0 then
            begin
               ZZ := ZZ + 1;
               If ZZ > 1 then  NewValue := NewValue + ';' ;
               NewValue := NewValue + PathList;
            end
            else begin
              isIncluded := True;
            end;
         end;

         if isIncluded Then
            RegWrite(HKEY_CURRENT_USER, RegKey, RegValue , NewValue)

      end;
end;

procedure TForm2.Button1Click(Sender: TObject);
var InstallDir, RegKey: string;
begin

   If not IsUserAnAdmin() then     //requires admin privileges !
   begin
     MessageDlg('UpdateTool must be run as ADMIN !' + #13#10 + 'UpdateTool will be terminated now !',mtInformation,[mbOk], 0, mbOk);
     Application.Terminate;
     exit;
   end;

   //Path to remove from all library paths in Delphi 10.3 Rio.
   //Hardcoded, but can be easily made editable !
   InstallDir := 'C:\Program Files\ComponentXXX'; //All other paths with the same root will also be removed

   RegKey := 'Software\Embarcadero\BDS\20.0\Library\';
   UpdateLibPath(RegKey + 'Win32', 'Search Path', InstallDir);
   UpdateLibPath(RegKey + 'Win32', 'Browsing Path', InstallDir);

   UpdateLibPath(RegKey + 'Win64', 'Search Path', InstallDir);
   UpdateLibPath(RegKey + 'Win64', 'Browsing Path', InstallDir);

   UpdateLibPath(RegKey + 'iOSDevice32', 'Search Path', InstallDir);
   UpdateLibPath(RegKey + 'iOSDevice32', 'Browsing Path', InstallDir);

   UpdateLibPath(RegKey + 'iOSDevice64', 'Search Path', InstallDir);
   UpdateLibPath(RegKey + 'iOSDevice64', 'Browsing Path', InstallDir);

   UpdateLibPath(RegKey + 'Android32', 'Browsing Path', InstallDir);
   //The same for iOSSimulator, Linux64 and OSX32

   MessageDlg('Library Paths for Delphi DX10.3 Rio cleaned up !' ,mtInformation,[mbOk], 0, mbOk);

end;
[/SHOWTOGROUPS]
 
Последнее редактирование:

emailx45

Местный
Регистрация
5 Май 2008
Сообщения
3,571
Реакции
2,438
Credits
573
my sample to Capture screen (contents) from PageControl "TabSheet" (VCL) or "TabItem" (FMX) and save it on Bitmap file or print it!
[SHOWTOGROUPS=4,19,20]
Scenary:
  • Intel i7, 8GB
  • Windows 10 PRO build 1803
  • RAD Studio XE10.2.3
This project is for FireMonkey!
  • So it will not work on VCL projects, for the fact that I'm using the TABCONTROL component to capture its content through the "MakeScreenshot" function - not existing in VCL controls.
  • If you use "FOR NEXT" or similar, because of the "redesign" time of the screen, the "MakeScreenshot" function has not been able to get the image.
  • At least here on my system, I only got it once.
Код:
procedure TForm1.btnPrintMyTabSheetPleaseClick(Sender: TObject);
var
  xBmp: TBitmap;
  SceneScale: Single;
  i: Integer;
  iCurrentTabItem: Integer;
begin
  memoFileNames.Lines.Clear;
  //
  if (TabControl1.Controls.Count > 0) then
  begin
    try
      iCurrentTabItem := TabControl1.TabIndex;
      //
      if TabControl1.Scene <> nil then
        SceneScale := TabControl1.Scene.GetSceneScale
      else
        SceneScale := 1;
      //
      xBmp := TBitmap.Create(Round(TabControl1.Width * SceneScale), Round(TabControl1.Height * SceneScale));
      xBmp.BitmapScale := SceneScale;
      xBmp.Clear(0);
      //
      {
        "FOR NEXT" its works, but, I believe that is a bug on FireMonkey when trying
        MakeScreen very fast... sometimes works, and... normally dont!
        Then, change the TabItem manually, its ok!
      }
       // for i := 0 to (TabControl1.TabCount - 1) do  {uncomment for test}
      begin
        // TabControl1.TabIndex := i; // for change the TabItem   {uncomment for test}
        //
        if (TabControl1.ActiveTab.Controls.Count > 0) then // only Tab with some control!
        begin
          // MakeScreenShot  procedure call the "PaintTo()", then, you can repace it for "PaintTo()" like VCL example
          // with some changes, of course, if necessary!
          xBmp := TabControl1.MakeScreenshot; // Smile! You will be photographed!
          //
          if not xBmp.IsEmpty then // is not empty really?
          begin
            xBmp.SaveToFile(Format('myTabSheet%d.bmp', [TabControl1.TabIndex]));
            //
            ImageViewer1.Bitmap.LoadFromFile(Format('myTabSheet%d.bmp', [TabControl1.TabIndex]));
            //
            memoFileNames.Lines.Add(Format('TabItem%d was printed as myTabSheet%d.bmp', [TabControl1.TabIndex, TabControl1.TabIndex]));
          end;
        end;
        //
        // here, Im forcing on time to repaint the TabControl
        // but, on first time, dont capture the content of others TabItems (only current TabItem)
        // later, first time, its ok!
        //  ShowMessage('That way, the Screenshot can works or not :)');   {uncomment for test}
      end;
    finally
      xBmp.DisposeOf;
      xBmp := nil;
    end;
    //
    if (TabControl1.TabIndex <> iCurrentTabItem) then
      TabControl1.TabIndex := iCurrentTabItem;
  end
  else
    ShowMessage('There is not any controls on TabControl1');
end;

This project is for VCL version
  • now using PageControl1.PaintTo() function rather than PageControl1.Pages.Perform()
  • Now, all controls into PageControl - TabSheet will be captured on Screenshot too!
Код:
procedure TForm1.btnPrintTabSheetsClick(Sender: TObject);
var
  xBitmapTmp: TBitmap;
  i: Integer;
  iCurrentTabSheet: Integer;
begin
  memoResulted.Lines.Clear;
  iCurrentTabSheet := PageControl1.ActivePageIndex;
  //
  try
    xBitmapTmp := TBitmap.Create;
    xBitmapTmp.Width := PageControl1.Width;
    xBitmapTmp.Height := PageControl1.Height;
    xBitmapTmp.PixelFormat := pf32bit; // see on help better choice
    //
    for i := 0 to (PageControl1.PageCount - 1) do
    begin
      if PageControl1.Pages.ControlCount > 0 then
      begin
        try
          PageControl1.ActivePageIndex := i;
          xBitmapTmp.Canvas.Lock;
          //
          PageControl1.PaintTo(xBitmapTmp.Canvas.Handle, 0, 0);
        finally
          xBitmapTmp.Canvas.UnLock;
        end;
        //
        if not xBitmapTmp.Empty then
        begin
          xBitmapTmp.SaveToFile(Format('myTabSheet%d.bmp', [PageControl1.ActivePageIndex]));
          //
          Image2.Picture.Bitmap := xBitmapTmp;
          //
          memoResulted.Lines.Add('Printing... ' + PageControl1.Pages.Caption);
          //
          // ShowMessage('Stop please... I want to see the resulted');
        end;
      end;
    end;
  finally
    xBitmapTmp.DisposeOf; // multi-platform use
    xBitmapTmp := nil;
    //
    if (PageControl1.ActivePageIndex <> iCurrentTabSheet) then
      PageControl1.ActivePageIndex := iCurrentTabSheet;
  end;
end;
[/SHOWTOGROUPS]
 
Последнее редактирование:

emailx45

Местный
Регистрация
5 Май 2008
Сообщения
3,571
Реакции
2,438
Credits
573
Custom Managed Records Coming in Delphi 10.3
Marco Cantu - November 7, 2018
Beside inline variable declarations, Delphi 10.3 is going to offer another new Object Pascal language extension, custom managed records
[SHOWTOGROUPS=4,19,20]
Beside inline variable declaration, as explained in my recent blog post, the coming 10.3 version of Delphi will have another relevant addition to the Delphi language, namely the ability to define code to be executed when records are first initialized, disposed from memory and copied. Before we get to that, though, let me recap a few key elements of records in today's Delphi language.

Records in Recent Versions
In Modern Object Pascal (from Delphi 2009, if I remember) the record type constructor has gained many new features, from the ability to define methods to operators overloading. The main differentiator from class type remains the way memory is allocated. While a class based variable is just a reference to dynamically allocated memory, a record based variable has a copy of the actual data.

1552102945781.png

The core difference in memory layout is also related with the fact records lack virtual methods and inheritance, a key tenets of object-oriented programming. On the plus side, the way records are allocated in memory can help with memory management and make it faster as the memory is directly available skipping an extra allocation and deallocation operation.
The other large difference we don’t have time to explore in full is what happens when you pass a record as parameter to a function. By default, the compiler makes a copy of the entire record data. You can avoid the copy by passing the record by reference (var). These has deeper implications than it might seem.

Standard and Managed Records
Records can of course have fields of any type. When a record has plain (non-managed) fields, like numeric or other enumerated values there isn’t much to do for the compiler and disposing the record consist of getting rid of the memory location and likely making it available to be reused later. But if a record has a field of a type managed (in terms of memory) by the compiler, things get slightly more complex. An example would be a record with a string field. The string itself is reference counted, so when the record goes out of scope the string inside the record needs have its reference count decreased, which might lead to de-allocating the memory for the string. Therefore, when you are using such a managed record in a section of the code, the compiler automatically adds a try-finally block around that code, and makes sure the data is cleared even in case of an exception.

Custom Managed Records
So if managed records have existing for a long time, what does it mean that Delphi 10.3 will add support for them? What the language will provide is “custom” managed record. In other words, you will be able to declare a record with custom initialization and finalization code regardless of the data type of its fields, and you’ll be able to write such custom initialization and finalization code. You’d do so by adding a parameter-less constructor to the record type and a destructor (you can have one without the other, if you want). Here is a simple code snippet:

type
TMyRecord = record
Value: Integer;
constructor Create;
destructor Destroy;
end;


You’ll have of course to write the code of these two methods. The huge difference between this new constructor and what was previously available for records is the automatic invocation. In fact if you write something like:

procedure TForm5.btnMyRecordClick(Sender: TObject);
var
my1: TMyRecord;
begin
Log (my1.Value.ToString);
end;

you’ll end up invoking both the default constructor and the destructor, and you’ll end up with a try-finally block generated by the compiler for your managed record instance.
You can also explicitly invoke the record default constructor, in code like:

myrec := TMyRecord.Create;

There is of course the risk, depending on how you write the code, that the default constructor gets invoked twice, implicitly by the compiler and in your code. In case of inline variable declarations, this won’t happen, but in other cases it might.

The Assign Operator
Another new feature brought along with custom managed records is the ability to execute custom code to assign a record to another. Rather than copying the entire data, field by field, you might want to perform different tasks, keep a single copy of some of the fields, duplicate an object a record refers to, or any other custom operation. The new operator is invoked with the := syntax, but defined as “Assign”:

type
TMyRecord = record
Value: Integer;
class operator Assign (var Dest: TMyRecord; const [ref] Src: TMyRecord);

The operator definition must follow very precise rules, including having the first parameter as a reference parameter, and the second as var or const passed by reference. If you fail to do so, the compiler issues error messages like:

[dcc32 Error] E2617 First parameter of Assign operator must be a var parameter of the container type
[dcc32 Hint] H2618 Second parameter of Assign operator must be a const[Ref] or var parameter of the container type


The Assign operator is invoked if you write:

var
my1, my2: TMyRecord;
begin
my1.Value := 22;
my2 := my1;


The assign operator is used in conjunction with assignment operations like the one above, and also if you use an assignment to initialize a inline variable (in which case the default constructor is not called):

var my4 := my1;


Copy Constructor
There is however another interesting scenario, which is the case you are passing a record parameter or want to create a new record based on an existing one. To handle similar scenarios you can define a Copy constructor, that is a constructor that takes a record of the same type as parameter. In most cases, you’d also want a default constructor, so you need to mark them with the overload directive:

TMyRecord = record
constructor Create; overload;
constructor Create (const mr: TMyRecord); overload;


If you now define a method or procedure with a regular value parameter (not passed by const or var), when you invoke it, it will use the Copy constructor, not an assignment call:
procedure ProcessRec (mr: TMyRecord);

begin
Log (mr.Value.ToString);
end;


Notice that you also get the Destroy destructor called at the end of the procedure. Another way to invoke the Copy Constructor is to use the following inline variable declaration:

var my3 := TMyRecord.Create (my1);


Conclusion and Disclaimer
A very interesting use case for managed records is the implementation of smart pointers. I’ve written some code I’ll share in a future blog post. What I wanted to do today was only to share the overall concept.

This is another significant changes for the language, and it opens up even further use of record types. Notice, however, that some of the details of managed records are still subject to change until GA of Delphi 10.3.

Sources:
Для просмотра ссылки Войди или Зарегистрируйся
[/SHOWTOGROUPS]
 
Последнее редактирование:

emailx45

Местный
Регистрация
5 Май 2008
Сообщения
3,571
Реакции
2,438
Credits
573
Firemonkey: How to crop a photo in Delphi (Video lessons) - in PortugueseBR
Easy method and didatic for crop a image, for example, to create your "profile photo" in your app Mobile or Windows.You can change to VCL!


NOTE: You can change the subtitles for your language (google option for all languages)

One feature that leaves your mobile app with a more professional face is to allow your user to change his or her profile picture. But do not just send the new photo to replace the old image. Ideally, it can resize and crop the photo the way you want.

This feature is used in applications such as Facebook and Twitter, and allows a very nice customization of the photos!

1552103075586.png
[SHOWTOGROUPS=4,19,20]

Code source:
Для просмотра ссылки Войди или Зарегистрируйся
or
Для просмотра ссылки Войди или Зарегистрируйся
[/SHOWTOGROUPS]
 
Последнее редактирование:

emailx45

Местный
Регистрация
5 Май 2008
Сообщения
3,571
Реакции
2,438
Credits
573
SHA Hash with C++Builder and Delphi
Posted by Для просмотра ссылки Войди или Зарегистрируйся, 11 MAY 2018 (Embarcadero MVP)
1552103443112.png

I've always been fascinated by encryption & compression, but my favorite is probably the Для просмотра ссылки Войди или Зарегистрируйся. A hash function is a one-way algorithm that takes an input of any size and always produces the same size output. It is one-way in that there is information loss -- you can't easily go from the output to the input again. The cryptographic hash is a more secure version of the hash function. It is most often used in signing to validate that data hasn't been modified.
Per Для просмотра ссылки Войди или Зарегистрируйся, the ideal cryptographic hash function has five main properties:
  • it is Для просмотра ссылки Войди или Зарегистрируйся so the same message always results in the same hash
  • it is quick to compute the hash value for any given message
  • it is Для просмотра ссылки Войди или Зарегистрируйся to generate a message from its hash value except by trying all possible messages
  • a small change to a message should change the hash value so extensively that the new hash value appears uncorrelated with the old hash value
  • it is Для просмотра ссылки Войди или Зарегистрируйся to find two different messages with the same hash value
R7UNC3.png

The Message Digest family of cryptographic hashes used to be the main players in the area, but they were found to be insecure. Now SHA family rules as the main workhorse of modern cryptography.

The basis of hash support first appeared in the RTL around the 2009 release but in Для просмотра ссылки Войди или Зарегистрируйся (2015) we got the Для просмотра ссылки Войди или Зарегистрируйся unit, which brought the MD5, SHA-1, and Bob Jenkins hashes. Then in Для просмотра ссылки Войди или Зарегистрируйся (2015) it was expanded with Для просмотра ссылки Войди или Зарегистрируйся support. Most recently in Для просмотра ссылки Войди или Зарегистрируйся (2017) the hash functions were expanded to accept either a string or stream in addition to the original bytes input.

The SHA Family includes SHA-0, SHA-1, SHA-2, & SHA-3 family of hashes. SHA-0 is obsolete, and SHA-3 is an improvement on SHA-2. In practice I see most hashes using either SHA-1 or SHA-2. SHA-1 always produces a 160-bit (20-byte) hash (digest), while SHA-2 includes 224, 256, 384, and 512-bit outputs, making it both more secure and more flexible. SHA 256 & 512 represent 32 and 64-bit word size hash algorithms. The 224, 256, & 384 size digests are truncated versions of the 256 & 512 algorithms.

So how do you use it in C++Builder and Delphi? I'm glad you asked. Once you have included the System.Hash unit then you can use the methods of the THashSHA2 class to create the digest. I'll show you how to use GetHashString, but know there are other variations you can use too. The GetHashString takes either a string or a stream and returns a hexadecimal string of the hash.

In C++Builder your code would look like:
Код:
Edit512->Text = THashSHA2::GetHashString(
    EditMessage->Text,
    THashSHA2::TSHA2Version::SHA512);
and in Delphi your code would look like:
Код:
Edit512.Text := THashSHA2.GetHashString(
    EditMessage.Text,
    THashSHA2.TSHA2Version.SHA512).ToUpper;
I made a little sample app that generates all the different hashes from the text you provide. It is a FireMonkey app, so will work on all the platforms, but the hash code will work in any type of app. There are both C++ and Delphi versions included.
TRB50R.png
[SHOWTOGROUPS=4,19,20]
Sources: Для просмотра ссылки Войди или Зарегистрируйся
[/SHOWTOGROUPS]
 
Последнее редактирование:

emailx45

Местный
Регистрация
5 Май 2008
Сообщения
3,571
Реакции
2,438
Credits
573
3D Credits Scroll with Delphi (A little fun with Delphi for today’s Star Wars day!)
by Jim McKeeth, 04/May/2018
A little fun with Delphi for today’s Star Wars day!

This is a pretty simple 3D form with a 3D layout at an angle, and then a 2D layout with text and images is animated up the 3D layout. The only code is populating the labels as the animation kicks off automatically.

1552103527231.png


1552103537682.png

change the message to share with your friends. It is FireMonkey, and while I only tested it on Windows, it should work on Android, iOS, macOS, and even Linux if you are running Для просмотра ссылки Войди или Зарегистрируйся.


May the Fourth be with You!
1552103577588.png
[SHOWTOGROUPS=4,19,20]
source code: Для просмотра ссылки Войди или Зарегистрируйся
[/SHOWTOGROUPS]
 
Последнее редактирование:

emailx45

Местный
Регистрация
5 Май 2008
Сообщения
3,571
Реакции
2,438
Credits
573
My code to "Counting how many links exist in a webpage or similar content" like email message
[SHOWTOGROUPS=4,19,20]
unit Unit1;

interface

uses
Winapi.Windows,
Winapi.Messages,
System.SysUtils,
System.Variants,
System.Classes,
Vcl.Graphics,
Vcl.Controls,
Vcl.Forms,
Vcl.Dialogs,
Vcl.StdCtrls,
Vcl.OleCtrls,
SHDocVw,
Vcl.ExtCtrls,
Vcl.Buttons;

type
TForm1 = class(TForm)
pnlMiddle: TPanel;
pnlTop: TPanel;
pnlBottom: TPanel;
Memo1: TMemo;
WebBrowser1: TWebBrowser;
spdbtnLoadPage: TSpeedButton;
edtPageAddress: TEdit;
spdbtnHowManyLinks: TSpeedButton;
procedure FormCreate(Sender: TObject);
procedure spdbtnLoadPageClick(Sender: TObject);
procedure spdbtnHowManyLinksClick(Sender: TObject);
procedure edtPageAddressChange(Sender: TObject);
procedure edtPageAddressKeyPress(Sender: TObject; var Key: Char);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

uses
MSHTML;

var
htmlDoc : IHTMLDocument2;
allLinks : IHTMLElementCollection;
firstLink : IHTMLElement;
sbtnHowManyLinksText: String;

procedure TForm1.edtPageAddressChange(Sender: TObject);
begin
spdbtnLoadPage.Enabled := True;
spdbtnHowManyLinks.Enabled := False;
spdbtnHowManyLinks.Caption := sbtnHowManyLinksText;
end;

procedure TForm1.edtPageAddressKeyPress(Sender: TObject; var Key: Char);
begin
if (Key = #13) then
spdbtnLoadPage.Click;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
sbtnHowManyLinksText := spdbtnHowManyLinks.Caption;
pnlTop.Height := Trunc(Screen.Height * 0.40);
pnlBottom.Height := Trunc(Screen.Height * 0.40);
end;

procedure TForm1.spdbtnLoadPageClick(Sender: TObject);
begin
try
spdbtnLoadPage.Enabled := False;
WebBrowser1.Navigate(edtPageAddress.Text);
spdbtnHowManyLinks.Enabled := True;
except
on e: Exception do
begin
spdbtnHowManyLinks.Enabled := False;
ShowMessage(e.Message);
end;
end;
end;

procedure TForm1.spdbtnHowManyLinksClick(Sender: TObject);
var
URL: String;
i : Integer;
begin
Memo1.Lines.Clear;
//
htmlDoc := WebBrowser1.Document as IHTMLDocument2;
//
if htmlDoc <> nil then // some pages is "dynamic load", then, "htmlDoc" may be equal to "nil"
begin
allLinks := htmlDoc.Links;
//
spdbtnHowManyLinks.Caption := Format('%s = %d', [sbtnHowManyLinksText, allLinks.length]);
//
for i := 0 to allLinks.length - 1 do
begin
firstLink := allLinks.Item(i, '') as IHTMLElement;
URL := firstLink.toString;
Memo1.Lines.Add(Format('%.5d (%.5d) - %s', [i, i + 1, URL]));
end;
end
else
ShowMessage('htmlDoc = nil'#13'...wait the page load!');
end;

end.

[/SHOWTOGROUPS]

CONCLUSION:
- IT WORK, BUT NEED TO BE REFINED. OF COURSE!
- BUT IT IS NOT FOR EXPERT USER, JUST FOR "NOOB" TEST!
 
Последнее редактирование:

emailx45

Местный
Регистрация
5 Май 2008
Сообщения
3,571
Реакции
2,438
Credits
573
Did you know is possible use VCL and FMX (FireMonkey) togheter in your app?
Here my test about use of "VCL" and "FMX" objects togheter, to create one app to MS Windows!

Many want to use DLLs written in C / C ++ or another language along with their project in RAD Studio (Delphi or CBuilder), but they forget or do not know that a BPL is actually a binary library, such as a DLL, with due exceptions and differences in your call.

However, since a BPL is actually a binary Delphi / CBuilder code container, then this means you can create your own repository of objects (classes) and codes to use in your projects, in order to re-use their codes. (Remember one of the pillars of object-oriented language - Inheritance)

To use one framework within the other, in the case it may be: VCL within FMX, or FMX within VCL - you have to take a few basic steps.

You must create the objects that will be used by the other framework with a package (BPL / DCP), as RAD Studio does.
In your application project, VCL or FMX, you must inform that you will use a custom "RUNTIME PACKAGE", which is your newly created package.
Add the DCP file - not BPL file ok!
IT's NOT NECESSARY INSTALL THE PACKAGE IN YOUR IDE, JUST HAVE IT TO USE!
By default, RAD Studio saves the BPL and DCP files in your "Documents Public \ Embarcadero \ .... DCP and BPL sub-folders" - if you want, you can "copy it" for you project folder or any other place!
Just DONT FORGET where is it, ok!
After that, you simply inform in your application project, in the "USES" clause, which unit you intend to use, and which is inside your "package" that you created before.
Then you can use the objects and classes as you normally do when using the RAD Studio default packages.
Код:
My project VCL that will use my TForm FMX (FireMonkey)
-------------------------------------------------------------------------------

unit uVCLFormMain;

interface

uses
  Winapi.Windows,
  Winapi.Messages,
  System.SysUtils,
  System.Variants,
  System.Classes,
  Vcl.Graphics,
  Vcl.Controls,
  Vcl.Forms,
  Vcl.Dialogs,
  Vcl.StdCtrls,
  Vcl.Menus,
  //
  uFMXForm_inVCLproject  // in my package with my objects FMX
  //
    ;

type
  TVCLFormMain = class(TForm)
    Label1: TLabel;
    MainMenu1: TMainMenu;
    Files1: TMenuItem;
    About1: TMenuItem;
    CallFMXform1: TMenuItem;
    N1: TMenuItem;
    Exit1: TMenuItem;
    procedure CallFMXform1Click(Sender: TObject);
    procedure Exit1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  VCLFormMain: TVCLFormMain;

implementation

{$R *.dfm}

procedure TVCLFormMain.CallFMXform1Click(Sender: TObject);
var
  lFMXForm_inVCLprj: TfrmFMXForm_inVCLproject;
begin
  lFMXForm_inVCLprj := TfrmFMXForm_inVCLproject.Create(nil);
  try
    lFMXForm_inVCLprj.ShowModal;
  finally
    Self.SetFocus;
    //
    lFMXForm_inVCLprj.DisposeOf;
    lFMXForm_inVCLprj := nil;
  end;
end;

procedure TVCLFormMain.Exit1Click(Sender: TObject);
begin
  Close;
end;

end.


my TForm FireMonkey (FMX) used in my VCL project
-------------------------------------------------------------------------------

unit uFMXForm_inVCLproject;

interface

uses
  System.SysUtils,
  System.Types,
  System.UITypes,
  System.Classes,
  System.Variants,
  FMX.Types,
  FMX.Controls,
  FMX.Forms,
  FMX.Graphics,
  FMX.Dialogs,
  FMX.Layouts,
  FMX.StdCtrls,
  FMX.Controls.Presentation;

type
  TfrmFMXForm_inVCLproject = class(TForm)
    AniIndicator1: TAniIndicator;
    Layout1: TLayout;
    Label1: TLabel;
    StyleBook1: TStyleBook;
    ToolBar1: TToolBar;
    sbtnClickMe: TSpeedButton;
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure sbtnClickMeClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmFMXForm_inVCLproject: TfrmFMXForm_inVCLproject;

implementation

{$R *.fmx}

procedure TfrmFMXForm_inVCLproject.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  AniIndicator1.Enabled := False;
end;

procedure TfrmFMXForm_inVCLproject.FormCreate(Sender: TObject);
begin
  Position := TFormPosition.ScreenCenter;
end;

procedure TfrmFMXForm_inVCLproject.FormShow(Sender: TObject);
begin
  AniIndicator1.Enabled := False;
  AniIndicator1.Enabled := True;
end;

procedure TfrmFMXForm_inVCLproject.sbtnClickMeClick(Sender: TObject);
begin
  ShowMessage('Hello FMX project');
end;

end.


my project FireMonkey (FMX) that will use my TForm VCL
-------------------------------------------------------------------------------

unit uFMXFormMain;

interface

uses
  System.SysUtils,
  System.Types,
  System.UITypes,
  System.Classes,
  System.Variants,
  FMX.Types,
  FMX.Controls,
  FMX.Forms,
  FMX.Graphics,
  FMX.Dialogs,
  FMX.Controls.Presentation,
  FMX.StdCtrls,
  FMX.Layouts,
  //
  uVCLForm_inFMXproject  // in my package with my objects VCL
  //
    ;

type
  TFMXFormMain = class(TForm)
    Layout1: TLayout;
    ToolBar1: TToolBar;
    sbtnCallVCLForm: TSpeedButton;
    sbtnCloseApp: TSpeedButton;
    Label1: TLabel;
    StyleBook1: TStyleBook;
    procedure FormCreate(Sender: TObject);
    procedure sbtnCallVCLFormClick(Sender: TObject);
    procedure sbtnCloseAppClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FMXFormMain: TFMXFormMain;

implementation

{$R *.fmx}

procedure TFMXFormMain.FormCreate(Sender: TObject);
begin
  Position := TFormPosition.ScreenCenter;
end;

procedure TFMXFormMain.sbtnCallVCLFormClick(Sender: TObject);
var
  lVCLForm_inFMXprj: TfrmVCLForm_inFMXproject; // my TForm VCL
begin
  lVCLForm_inFMXprj := TfrmVCLForm_inFMXproject.Create(nil);
  try
    lVCLForm_inFMXprj.ShowModal;
  finally
    Self.Active := True;
    //
    lVCLForm_inFMXprj.DisposeOf;
    lVCLForm_inFMXprj := nil;
  end;
end;

procedure TFMXFormMain.sbtnCloseAppClick(Sender: TObject);
begin
  Close;
end;

end.
-------------------------------------------------------------------------------

my TForm VCL used in my project FireMonkey (FMX)
-------------------------------------------------------------------------------

unit uVCLForm_inFMXproject;

interface

uses
  Winapi.Windows,
  Winapi.Messages,
  System.SysUtils,
  System.Variants,
  System.Classes,
  Vcl.Graphics,
  Vcl.Controls,
  Vcl.Forms,
  Vcl.Dialogs,
  Vcl.StdCtrls,
  Vcl.ExtCtrls,
  Vcl.ComCtrls,
  Vcl.ToolWin,
  Vcl.Menus,
  System.ImageList,
  Vcl.ImgList,
  System.Actions,
  Vcl.ActnList,
  Vcl.StdActns,
  Vcl.Themes;

type
  TfrmVCLForm_inFMXproject = class(TForm)
    Label1: TLabel;
    Panel1: TPanel;
    Animate1: TAnimate;
    ToolBar1: TToolBar;
    Button1: TButton;
    Button2: TButton;
    ToolButton1: TToolButton;
    ToolButton2: TToolButton;
    ComboBox1: TComboBox;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormShow(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure ComboBox1Change(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmVCLForm_inFMXproject: TfrmVCLForm_inFMXproject;

implementation

{$R *.dfm}

const
  lPathStyles = 'C:\Users\Public\Documents\Embarcadero\Studio\20.0\Styles';

procedure TfrmVCLForm_inFMXproject.Button1Click(Sender: TObject);
begin
  ShowMessage('Hello VCL project');
end;

procedure TfrmVCLForm_inFMXproject.Button2Click(Sender: TObject);
begin
  Close;
end;

procedure TfrmVCLForm_inFMXproject.ComboBox1Change(Sender: TObject);
begin
  if (ComboBox1.Items.Count > 0) then
    TStyleManager.SetStyle(ComboBox1.Text);
end;

procedure TfrmVCLForm_inFMXproject.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Animate1.Active := False;
end;

procedure TfrmVCLForm_inFMXproject.FormCreate(Sender: TObject);
var
  lStyleName: string;
begin
  Position := TPosition.poScreenCenter;
  //
  for lStyleName in TStyleManager.StyleNames do
    ComboBox1.Items.Add(lStyleName);
  //
  if (ComboBox1.Items.Count > 0) then
    ComboBox1.ItemIndex := 0;
end;

procedure TfrmVCLForm_inFMXproject.FormShow(Sender: TObject);
begin
  Animate1.Active := False;
  Animate1.Active := True;
end;

initialization

finalization

end.
screen001.png

screen002.png
[SHOWTOGROUPS=4,19,20]
my code source complete: (compressed using 7-Zip last) - 14 servers
Для просмотра ссылки Войди или Зарегистрируйся
[/SHOWTOGROUPS]
 
Последнее редактирование:

emailx45

Местный
Регистрация
5 Май 2008
Сообщения
3,571
Реакции
2,438
Credits
573
here my examples of:
- Creating Columns by code in StringGrid in VCL and FireMonkey (FMX)
- VCL project

Screen002.png
[SHOWTOGROUPS=4,19,20]
unit uFormMain;

interface

uses
Winapi.Windows,
Winapi.Messages,
System.SysUtils,
System.Variants,
System.Classes,
Vcl.Graphics,
Vcl.Controls,
Vcl.Forms,
Vcl.Dialogs,
Vcl.StdCtrls,
Vcl.Grids;

type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
btnCreatingStringGridColumnsRow: TButton;
btnComboBoxVisibleOrNot: TButton;
Memo1: TMemo;
btnDeleteMyCmbBoxOnStringGrid: TButton;
procedure btnCreatingStringGridColumnsRowClick(Sender: TObject);
procedure btnComboBoxVisibleOrNotClick(Sender: TObject);
procedure StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer; var CanSelect: Boolean);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure btnDeleteMyCmbBoxOnStringGridClick(Sender: TObject);
published
procedure MyCmbBoxCloseUp(Sender: TObject); // my event when close my choice in MyCmbBox
private
{ Private declarations }
procedure prcCreateMyCmbBox;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

var
lColInSelectCell: Integer;
lRowInSelectCell: Integer;
lMyCmbBox: TComboBox;

procedure TForm1.btnCreatingStringGridColumnsRowClick(Sender: TObject);
var
i: Integer;
lRectCell: TRect;
begin
// StringGrid in VCL project
//
//
StringGrid1.ColCount := 0; // removing...
StringGrid1.RowCount := 0; // removing...
//
StringGrid1.ColCount := 3;
StringGrid1.RowCount := 2;
//
for i := 0 to (StringGrid1.ColCount - 1) do
StringGrid1.ColWidths := 120; // Col #n, width
//
StringGrid1.ColWidths[0] := 150; // Col #1, width
//
StringGrid1.RowHeights[1] := 120; // Row #2 width
// Cells[ col, row] := 'string-value'
StringGrid1.Cells[0, 0] := 'string_value01';
StringGrid1.Cells[1, 0] := 'string_value02';
StringGrid1.Cells[2, 0] := 'string_value02';
StringGrid1.Cells[0, 1] := 'string_value11';
StringGrid1.Cells[1, 1] := 'string_value12';
StringGrid1.Cells[2, 1] := 'string_value12';
//
// StringGrid1.Cols[1].Clear; // clean all Col #2
//
{
lRectCell := StringGrid1.CellRect(lCol, lRow);
//
// position of TComboBox on StringGrid
lRectCell.Top := lRectCell.Top + StringGrid1.Top;
lRectCell.Left := lRectCell.Left + StringGrid1.Left;
lRectCell.Bottom := lRectCell.Bottom + StringGrid1.Top;
lRectCell.Right := lRectCell.Right + StringGrid1.Left;
//
lMyCmbBox.Top := lRectCell.Top + 1;
lMyCmbBox.Left := lRectCell.Left + 1;
lMyCmbBox.Height := (lRectCell.Bottom + 1) - lRectCell.Top;
}
// ---------- position end ----------
//
// lMyCmbBox.DropDownCount := 8;
// lMyCmbBox.ItemHeight := 20;
//
// StringGrid1.Objects[0, 0] := lMyCmbBox;
// StringGrid1.Cells[0, 0] := 'Added one ' + StringGrid1.Objects[0, 0].ToString;
//

//
(*
if StringGrid1.Objects[1, 1] <> nil then
ShowMessage(StringGrid1.Objects[1, 1].ToString + ' Show #1 ');
// Col, Row
StringGrid1.Objects[1, 1] := lMyCmbBox;
//
//TComboBox(StringGrid1.Objects[1, 1]).Items.Add('Item1'); // add items in lMyCmbBox
//TComboBox(StringGrid1.Objects[1, 1]).Items.Add('Item2'); // add items in lMyCmbBox
//TComboBox(StringGrid1.Objects[1, 1]).Items.Add('Item3'); // add items in lMyCmbBox
//TComboBox(StringGrid1.Objects[1, 1]).ItemIndex := 0;
//
// TObject(StringGrid1.Objects[1, 3]).Free;
// you need release the object, because, StringList dont do it!
// lMyCmbBox.Free; {or lMyCmbBox.DisposeOf and later lMyCmbBox := Nil; }
//
if StringGrid1.Objects[1, 1] <> nil then
ShowMessage(StringGrid1.Objects[1, 1].ToString + ' Show #2 ');
//
*)
//
if (StringGrid1.Objects[0, 0] = nil) or (StringGrid1.Objects[0, 0].ClassType <> TComboBox) then
prcCreateMyCmbBox;
//
Memo1.Lines.Clear;
Memo1.Lines.Add(Format('StringGrid1.Cols[1].Text = %s', [StringGrid1.Cols[1].Text]));
Memo1.Lines.Add(Format('StringGrid1.Rows[0].Text = %s', [StringGrid1.Rows[0].Text])); // all colunms in 'n' row
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if Assigned(lMyCmbBox) then
lMyCmbBox.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
StringGrid1.ColWidths[0] := 150;
//
prcCreateMyCmbBox;
end;

procedure TForm1.MyCmbBoxCloseUp(Sender: TObject);
begin
Memo1.Lines.Add('MyCmbBoxCloseUp --> ' + (Sender as TComboBox).Name + ' in OnCloseUp');
//
StringGrid1.Cells[lColInSelectCell, lRowInSelectCell] := (Sender as TComboBox).Items[(Sender as TComboBox).ItemIndex];
(Sender as TComboBox).Visible := False;
//
// focus on StringGrid, not in Cells[ c, r] current! Just a hack!
StringGrid1.SetFocus;
end;

procedure TForm1.prcCreateMyCmbBox;
begin
Memo1.Lines.Clear;
//
Randomize;
//
lMyCmbBox := TComboBox.Create(nil); // NOTE: StringGrid1 dont destroy its objects!
lMyCmbBox.Name := Format('MyCmbBox%d', [Random(10000000)]);
lMyCmbBox.Parent := Form1; // need some parent to the object!
//
lMyCmbBox.Visible := False;
//
lMyCmbBox.OnCloseUp := MyCmbBoxCloseUp;
//
lMyCmbBox.Text := lMyCmbBox.Name;
lMyCmbBox.Items.Add('Item1');
lMyCmbBox.Items.Add('Item2');
lMyCmbBox.Items.Add('Item3');
lMyCmbBox.ItemIndex := 0;
//
StringGrid1.Objects[0, 0] := lMyCmbBox; // add this control to first cell on StringGrid
//
StringGrid1.Options := StringGrid1.Options - [TGridOption.goRangeSelect]; // dont select cell range
end;

procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer; var CanSelect: Boolean);
var
lRectCell: TRect;
begin
if (StringGrid1.Objects[ACol, ARow] <> nil) { and (StringGrid1.Objects[ACol, ARow].ClassType = TComboBox) } then
begin
Memo1.Lines.Add('StringGrid1SelectCell --> ' + TComboBox(StringGrid1.Objects[ACol, ARow]).Name + ' in OnSelectCell');
//
lColInSelectCell := ACol;
lRowInSelectCell := ARow;
//
lRectCell := StringGrid1.CellRect(ACol, ARow);
// position of TComboBox on StringGrid
lRectCell.Top := lRectCell.Top + StringGrid1.Top;
lRectCell.Left := lRectCell.Left + StringGrid1.Left;
lRectCell.Bottom := lRectCell.Bottom + StringGrid1.Top;
lRectCell.Right := lRectCell.Right + StringGrid1.Left;
//
TComboBox(StringGrid1.Objects[ACol, ARow]).Top := lRectCell.Top + 1;
TComboBox(StringGrid1.Objects[ACol, ARow]).Left := lRectCell.Left + 1;
TComboBox(StringGrid1.Objects[ACol, ARow]).Height := (lRectCell.Bottom + 1) - lRectCell.Top;
//
TComboBox(StringGrid1.Objects[ACol, ARow]).Visible := True;
TComboBox(StringGrid1.Objects[ACol, ARow]).DroppedDown := True;
end;
//
end;

procedure TForm1.btnComboBoxVisibleOrNotClick(Sender: TObject);
begin
if (StringGrid1.Objects[0, 0] <> nil) and (StringGrid1.Objects[0, 0] is TComboBox) then
TComboBox(StringGrid1.Objects[0, 0]).Visible := not TComboBox(StringGrid1.Objects[0, 0]).Visible
else
ShowMessage('StringGrid1.Objects[0, 0]=nil or Is not a TComboBox');
end;

procedure TForm1.btnDeleteMyCmbBoxOnStringGridClick(Sender: TObject);
var
lObjName: String;
begin
if (StringGrid1.Objects[0, 0] <> nil) and (StringGrid1.Objects[0, 0].ClassType = TComboBox) then
begin
lObjName := TComboBox(StringGrid1.Objects[0, 0]).Name;
//
StringGrid1.Objects[0, 0] := nil;
TComboBox(StringGrid1.Objects[0, 0]).Free;
//
StringGrid1.Cells[0, 0] := Format('%s deleted!', [lObjName]);
//
Memo1.Lines.Clear;
Memo1.Lines.Add(Format('The obj [%s], was destroyed!', [lObjName]));
end
else
ShowMessage('(StringGrid1.Objects[0, 0] = nil) or (StringGrid1.Objects[0, 0].ClassType <> TComboBox)');
end;

end.

Для просмотра ссылки Войди или Зарегистрируйся

[/SHOWTOGROUPS]
 
Последнее редактирование:

emailx45

Местный
Регистрация
5 Май 2008
Сообщения
3,571
Реакции
2,438
Credits
573
- Creating Columns by code in StringGrid in VCL and FireMonkey (FMX)
- FMX project

Screen001.png
[SHOWTOGROUPS=4,19,20]
unit uFormMain;

interface

uses
System.SysUtils,
System.Types,
System.UITypes,
System.Classes,
System.Variants,
FMX.Types,
FMX.Controls,
FMX.Forms,
FMX.Graphics,
FMX.Dialogs,
// TStringGrid units added
System.Rtti,
FMX.Grid.Style,
FMX.Controls.Presentation,
FMX.ScrollBox,
FMX.Grid,
FMX.StdCtrls,
FMX.Memo
//
;

type
TfrmMainUnit = class(TForm)
StringGrid1: TStringGrid;
btnAddTColumsInStringGrid: TButton;
btnAddManyColumnsInStringGrid: TButton;
btnDeleteColumnOnStringGrid: TButton;
Memo1: TMemo;
procedure btnAddTColumsInStringGridClick(Sender: TObject);
procedure btnAddManyColumnsInStringGridClick(Sender: TObject);
procedure btnDeleteColumnOnStringGridClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
procedure prcLog(lClearMemo: Boolean = True);
public
{ Public declarations }
end;

var
frmMainUnit: TfrmMainUnit;

implementation

{$R *.fmx}

{
//added on project source - (Project->View Source)
ReportMemoryLeaksOnShutdown := True; // if leak memory!
}
{
// Options default:

// StringGrid1.Options := [TGridOption.ColumnResize, TGridOption.Editing, TGridOption.ColumnMove, TGridOption.ColLines, TGridOption.RowLines, TGridOption.Tabs,
// TGridOption.Header, TGridOption.HeaderClick, AutoDisplacement]
}
{
if (StringGrid1.ColumnCount <= 0) or (StringGrid1.Columns[0].ChildrenCount <= 0) then
begin
ShowMessage('(StringGrid1.ColumnCount <= 0) or (StringGrid1.Columns[0].ChildrenCount <= 0');
exit;
end;
//
ShowMessage(StringGrid1.Columns[0].ChildrenCount.ToString);
StringGrid1.Columns[0].DeleteChildren; // delete any children in this column
}
//
procedure TfrmMainUnit.btnAddTColumsInStringGridClick(Sender: TObject);
var
// TColumns type pre-defined - start
{
Column1: TColumn;
CheckColumn1: TCheckColumn;
DateColumn1: TDateColumn;
TimeColumn1: TTimeColumn;
PopupColumn1: TPopupColumn;
CurrencyColumn1: TCurrencyColumn;
FloatColumn1: TFloatColumn;
FloatColumn2: TFloatColumn;
IntegerColumn1: TIntegerColumn;
GlyphColumn1: TGlyphColumn;
}
StringColumn1: TStringColumn;
//
begin
//
// btnAddTColumsInStringGrid.Enabled := False; // only add 1x for test
//
// creating the objects FMX to add in my TStringGrid FMX
{
Column1 := TColumn.Create(StringGrid1);
CheckColumn1 := TCheckColumn.Create(StringGrid1);
DateColumn1 := TDateColumn.Create(StringGrid1);
TimeColumn1 := TTimeColumn.Create(StringGrid1);
PopupColumn1 := TPopupColumn.Create(StringGrid1);
CurrencyColumn1 := TCurrencyColumn.Create(StringGrid1);
FloatColumn1 := TFloatColumn.Create(StringGrid1);
FloatColumn1.ShowThousandSeparator := False;
FloatColumn2 := TFloatColumn.Create(StringGrid1);
FloatColumn2.ShowThousandSeparator := False;
IntegerColumn1 := TIntegerColumn.Create(StringGrid1);
GlyphColumn1 := TGlyphColumn.Create(StringGrid1);
}
StringColumn1 := TStringColumn.Create(StringGrid1);
StringColumn1.Name := Format('obj_SG_ColName%d', [StringGrid1.ColumnCount + 1]);
StringColumn1.Header := StringColumn1.Name;
StringColumn1.Width := 110.0; // Single type
StringColumn1.Parent := StringGrid1;
//
StringGrid1.AddObject(StringColumn1);
StringGrid1.Cells[0, 0] := 'the value';
end;

procedure TfrmMainUnit.btnAddManyColumnsInStringGridClick(Sender: TObject);
var
StringColumnS: Array [0 .. 3] of TStringColumn; // 4 columns!
i: Integer;
x: Integer;
lRow: Integer;
lCol: Integer;
lRowMax: Integer;
begin
//
// btnAddManyColumnsInStringGrid.Enabled := False; // only add 1x for test
//
lRowMax := 3; // [3 rows X 4 cols]
//
for i := Low(StringColumnS) to High(StringColumnS) do
begin
StringColumnS := TStringColumn.Create(StringGrid1);
StringColumnS.Name := Format('obj_SG_ColName%d', [StringGrid1.ColumnCount + 1]);
StringColumnS.Header := StringColumnS.Name;
StringColumnS.Width := 110.0; // Single type
StringColumnS.Parent := StringGrid1;
//
StringGrid1.AddObject(StringColumnS);
//
for x := 0 to (lRowMax - 1) do
begin
lRow := x;
lCol := (StringGrid1.ColumnCount - 1);
// values to cells
StringGrid1.Cells[lCol, lRow] := Format('[%d, %d]', [lCol, lRow]);
end;
end;
end;

procedure TfrmMainUnit.btnDeleteColumnOnStringGridClick(Sender: TObject);
var
i: Integer;
lObjColumnToDelete: TFmxObject;
lString: String;
begin
lString := '';
//
if (StringGrid1.ColumnCount <= 0) or (StringGrid1.Selected < 0) then
begin
prcLog();
Memo1.Lines.Add('');
Memo1.Lines.Add('(StringGrid1.ColumnCount <= 0) or (StringGrid1.Selected < 0)');
exit;
end;
//
// column selected or anyone valid!
lObjColumnToDelete := StringGrid1.Columns[StringGrid1.Selected];
//
Memo1.Lines.Clear;
Memo1.Lines.Add(Format('lObjColumnToDelete = %s', [lObjColumnToDelete.Name]));
//
// First, remove the column (ojb) from StringGrid (children list)!
// BUT, it dont is released from memory! The obj exist, yet! IF you try create it again, booommm! Error!
StringGrid1.RemoveObject(lObjColumnToDelete);
//
// NOW, kill the column (obj/component/class) from memory!
// Then, you can create again, include with same name!
// Else, you can have "memory leaks" when end your app!
//
lObjColumnToDelete.Free;
//
prcLog(False);
end;

procedure TfrmMainUnit.FormCreate(Sender: TObject);
begin
prcLog;
end;

procedure TfrmMainUnit.prcLog(lClearMemo: Boolean = True);
var
i: Integer;
lString: String;
begin
lString := '';
//
for i := 0 to (StringGrid1.ComponentCount - 1) do
begin
lString := Format('%s, %s, %s'#13#10, [lString, StringGrid1.Components.ClassName, StringGrid1.Components.Name]);
end;
//
if lClearMemo then
Memo1.Lines.Clear;
//
Memo1.Lines.Add(Format('Components in StringGrid'#13'%s', [lString]));
Memo1.Lines.Add('');
Memo1.Lines.Add(Format('# of Columns = %d', [StringGrid1.ColumnCount]));
end;

end.

Для просмотра ссылки Войди или Зарегистрируйся
[/SHOWTOGROUPS]
 
Последнее редактирование:

emailx45

Местный
Регистрация
5 Май 2008
Сообщения
3,571
Реакции
2,438
Credits
573
my project test, VCL / FMX using LiveBinding to link my Class TPersons with my StringGird
thanks to Thulio Bittencourt MVP Embarcadero Brasil
using POO code and manual instructions to link my TPersons class to the component StringGrid

Screen-Live-Binding-and-Code-POO-FMX-example.png

Screen-Live-Binding-and-Code-POO-VCL-example.png
[SHOWTOGROUPS=4,19,20]
362KB just:
Для просмотра ссылки Войди или Зарегистрируйся
[/SHOWTOGROUPS]
 
Последнее редактирование:

emailx45

Местный
Регистрация
5 Май 2008
Сообщения
3,571
Реакции
2,438
Credits
573
my example for add Tag in TreeNode from TreeView and delete any item indicated by Tag
  • Like imitating a TAG property from components, using a OBJECT (in true, a Type RECORD with a field) - so easy!
  • Then, stay more easy find any TreeNode with a specific value on new "Tag" attribute
TreeView_Items_Tag_VCL_project_For_While.png
[SHOWTOGROUPS=4,19,20]
Source complete: Для просмотра ссылки Войди или Зарегистрируйся

Код:
unit uFormMain;

interface

uses
  Winapi.Windows,
  Winapi.Messages,
  System.SysUtils,
  System.Variants,
  System.Classes,
  Vcl.Graphics,
  Vcl.Controls,
  Vcl.Forms,
  Vcl.Dialogs,
  Vcl.ComCtrls,
  Vcl.StdCtrls,
  Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    TreeView1: TTreeView;
    btnCreateMyTreeNodes_WithoutTAG: TButton;
    Memo1: TMemo;
    rgrpTreeViewSort: TRadioGroup;
    btnDeleteThisTreeNodeWithError: TButton;
    btnDeleteOneItemTreeNode_WithTag_Or_Not: TButton;
    btnCreateMyTreeNodes_WithTAG: TButton;
    procedure btnCreateMyTreeNodes_WithoutTAGClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure rgrpTreeViewSortClick(Sender: TObject);
    procedure btnDeleteThisTreeNodeWithErrorClick(Sender: TObject);
    procedure btnDeleteOneItemTreeNode_WithTag_Or_NotClick(Sender: TObject);
    procedure btnCreateMyTreeNodes_WithTAGClick(Sender: TObject);
  private
    procedure prcListAllTreeNodes(lTreeView: TTreeView; lCountBefore: Integer = -1);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

type
  TmyRecord = record
    FTag: Integer;
  end;

var
  lCountBeforeAnyAction: Integer;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Memo1.Lines.Clear;
end;

procedure TForm1.rgrpTreeViewSortClick(Sender: TObject);
begin
  TreeView1.SortType := TSortType(rgrpTreeViewSort.ItemIndex);
  prcListAllTreeNodes(TreeView1);
end;

procedure TForm1.prcListAllTreeNodes(lTreeView: TTreeView; lCountBefore: Integer = -1);
var
  i: Integer;
  lTreeNode: TTreeNode;
  lIndex: Integer;
  lParent: String;
  lAbsoluteIndex: Integer;
  lItemText: String;
  lTag: Integer;
begin
  Memo1.Lines.Clear;
  //
  if (lTreeView = nil) or (lTreeView.Items.Count = 0) then
  begin
    Memo1.Lines.Add('(lTreeView = nil) or (lTreeView.Items.Count = 0)');
    Exit;
  end;
  //
  Memo1.Lines.Add(Format('TreeView1.Items.Count = %d (before)', [lCountBefore]));
  Memo1.Lines.Add('-----------------------------------------');
  //
  for i := 0 to (lTreeView.Items.Count - 1) do
  begin
    lTreeNode := lTreeView.Items[i];
    // -----------------------------
    lParent := 'nil';
    if (lTreeNode.Parent <> nil) then
      lParent := lTreeNode.Parent.Text;
    { Parent:
      Identifies the parent node of the tree node.
      A "Parent" node is ONE LEVEL HIGHER THAN the node and contains the node as a subnode.
    }
    // -----------------------------
    lAbsoluteIndex := lTreeNode.AbsoluteIndex;
    { AbsoluteIndex:
      Indicates the index of the tree node RELATIVE TO THE FIRST TREE NODE in a tree node.
      Use AbsoluteIndex to determine absolute position of a node in a tree nodes object.
      The first tree node in a tree nodes object has an index of "0" and subsequent nodes are numbered sequentially.
      If a node has any children, its "AbsoluteIndex" is ONE LESS THAN the index of its first child.
    }
    // -----------------------------
    lIndex := lTreeNode.Index;
    { Index:
      Specifies the position of the node in the LIST OF CHILD NODES maintained by its parent node.
      Use "Index" to determine the position of the NODE RELATIVE  to its SIBLING NODES. (brothers)
      The FIRST CHILD of the parent node has an "Index" value of "0", and subsequent children are indexed sequentially.
    }
    // -----------------------------
    lItemText := lTreeNode.Text;
    { Text:
      Specifies the LABEL that identifies a tree node.
      Use "Text" to specify the string that is displayed in the tree view.
      The value of "Text" can be assigned directly at run-time or can be set within the TreeView Items Editor while modifying the Items property
      of the TTreeView component.
      If the tree view allows users to edit its nodes, read "Text" to determine the value given the node by the user.
    }
    //
    Memo1.Lines.Add(Format('TreeView1.Handle = %d, Parent = %s / AbsoluteIndex = %d / Index = %d / Text = %s / TmyRecord(lTreeNode.Data).FTag = %d', [TreeView1.Handle, lParent, lAbsoluteIndex, lIndex,
      lItemText, TmyRecord(lTreeNode.Data).FTag]));
  end;
  //
  Memo1.Lines.Add('-----------------------------------------');
  Memo1.Lines.Add(Format('TreeView1.Items.Count = %d (later)', [TreeView1.Items.Count]));
end;

procedure TForm1.btnCreateMyTreeNodes_WithoutTAGClick(Sender: TObject);
{ Add() -> Adds a new tree node to a tree view control.

  The node is added as the last sibling (brother) of the Sibling parameter.
  The S parameter specifies the Text property of the new node.

  Add returns the node that has been added.
  If the tree view is sorted, Add inserts the node in the correct sort order position
  rather than as the last child of the Sibling parameter's parent.
}
var
  lTreeNode: TTreeNode;
  lTreeNodeChild: TTreeNode;
  i: Integer;
  lIndex: Integer;
  lAbsoluteIndex: Integer;
  lItemText: String;
begin
  TreeView1.Items.Clear;
  //
  // all, returns a TTreeNode obj!
  lTreeNode := TreeView1.Items.Add(nil, Format('root_item1 = %d (nil)', [-1])); // -1 will be = NIL, for while!
  // still adding in root level!
  TreeView1.Items.Add(lTreeNode, Format('root1_item2 = %d (lTreeNode.AbsoluteIndex)', [lTreeNode.AbsoluteIndex]));
  // testing delete TreeNode with this Text
  TreeView1.Items.AddFirst(nil, 'Delete Me!'); // Format('AddFirst_1 = %d (nil)', [-1]));
  TreeView1.Items.AddFirst(lTreeNode, Format('AddFirst_2 = %d (lTreeNode.AbsoluteIndex)', [lTreeNode.AbsoluteIndex]));
  //
  TreeView1.Items.Add(nil, Format('root_item3 = %d (nil)', [-1]));
  TreeView1.Items.Add(nil, Format('root_item4 = %d (nil)', [-1]));
  // 3 - will be the first (AbsoluteIndex = 0), because it was add later...
  TreeView1.Items.AddFirst(nil, Format('AddFirst_3 = %d (nil)', [-1]));
  //
  lTreeNodeChild := TreeView1.Items.AddChild(lTreeNode, Format('AddChild_1 in lTreeNode[%d]', [lTreeNode.AbsoluteIndex]));
  TreeView1.Items.AddChildFirst(lTreeNode, Format('AddChildFirst_1 in lTreeNode[%d]', [lTreeNode.AbsoluteIndex])); // 1
  TreeView1.Items.AddChild(lTreeNode, Format('Delete Me!', [lTreeNode.AbsoluteIndex]));
  TreeView1.Items.AddChild(lTreeNode, Format('AddChild_3 in lTreeNode[%d]', [lTreeNode.AbsoluteIndex]));
  // 0 - will be the first (AbsoluteIndex = 0), because it was add later...
  TreeView1.Items.AddChildFirst(lTreeNode, Format('AddChildFirst_2 in lTreeNode[%d]', [lTreeNode.AbsoluteIndex]));
  //
  lTreeNode.Expand(True); // expand childs recursivelly
  // ----------------------
  prcListAllTreeNodes(TreeView1, TreeView1.Items.Count);
end;

procedure TForm1.btnDeleteOneItemTreeNode_WithTag_Or_NotClick(Sender: TObject);
var
  lTreeNode: TTreeNode;
  lTreeNodeTmp: TTreeNode;
  lItemsDeleted: Integer;
begin
  if (TreeView1.Items.Count <= 0) then
  begin
    ShowMessage('(TreeView1.Items.Count <= 0)');
    Exit;
  end;
  //
  lItemsDeleted := 0;
  lCountBeforeAnyAction := TreeView1.Items.Count;
  //
  lTreeNode := TreeView1.Items.GetFirstNode;
  //
  while (lTreeNode <> nil) do
  begin
    Memo1.Lines.Add(Format('AbsoluteIndex = %d / Index = %d / Text = %s', [lTreeNode.AbsoluteIndex, lTreeNode.Index, lTreeNode.Text]));
    //
    // if (Trim(lTreeNode.Text) = 'Delete Me!') then  {this works - not problem!}
    if (TmyRecord(lTreeNode.Data).FTag = 4) then
    begin
      lTreeNodeTmp := lTreeNode.GetNext; // lTreeNode.GetNext;
      TreeView1.Items.Delete(lTreeNode);
      lTreeNode := lTreeNodeTmp;
      //
      Inc(lItemsDeleted);
    end
    else
      lTreeNode := lTreeNode.GetNext;
  end;
  //
  prcListAllTreeNodes(TreeView1, lCountBeforeAnyAction);
  //
  Memo1.Lines.Add('-----------------------------------------');
  Memo1.Lines.Add(Format('Items deleted = %d', [lItemsDeleted]));
end;

procedure TForm1.btnDeleteThisTreeNodeWithErrorClick(Sender: TObject);
var
  i: Integer;
  lItemsDeleted: Integer;
begin
  if (TreeView1.Items.Count <= 0) then
  begin
    ShowMessage('(TreeView1.Items.Count <= 0)');
    Exit;
  end;
  //
  lItemsDeleted := 0;
  lCountBeforeAnyAction := TreeView1.Items.Count;
  //
  try
    for i := 0 to (TreeView1.Items.Count - 1) do
    begin
      // can occur the error, because we're deleting one Node, then, the (Count-1) will be ((Count-1)-1)
      // and the last Item dont exist anymore!
      //
      if (TreeView1.Items[i].AbsoluteIndex = 4) then
        // Use the "DeleteChildren" method to "delete all children" of a tree node, freeing all associated memory!
        TreeView1.Items[i].Delete;
      //
      Inc(lItemsDeleted);
    end;
  except
    on E: Exception do
    begin
      ShowMessage(Format('Error = %s'#13'Trying delete Items[%d] dont exist!...(remember: Count-1)'#13'TreeView1.Items.Count = %d Items', [E.Message, i, TreeView1.Items.Count]));
    end;
  end;
  //
  prcListAllTreeNodes(TreeView1, lCountBeforeAnyAction);
  //
  Memo1.Lines.Add('-----------------------------------------');
  Memo1.Lines.Add(Format('Items deleted = %d ( Inconsistence in Count property! )', [lItemsDeleted]));
end;

procedure TForm1.btnCreateMyTreeNodes_WithTAGClick(Sender: TObject);
var
  lTreeNode: TTreeNode;
  lTreeNodeChild: TTreeNode;
  i: Integer;
  lIndex: Integer;
  lAbsoluteIndex: Integer;
  lItemText: String;
  lTag: TmyRecord;
begin
  TreeView1.Items.Clear;
  //
  // all, returns a TTreeNode obj!
  lTag.FTag := 1;
  lTreeNode := TreeView1.Items.AddObject(nil, Format('root_item1 = %d (nil)', [-1]), Pointer(lTag)); // -1 will be = NIL, for while!
  // all, returns a TTreeNode obj!
  lTag.FTag := 2;
  lTreeNode := TreeView1.Items.AddObject(nil, Format('root_item1 = %d (nil)', [-1]), Pointer(lTag)); // -1 will be = NIL, for while!
  // still adding in root level!
  lTag.FTag := 3;
  TreeView1.Items.AddObject(lTreeNode, Format('root1_item2 = %d (lTreeNode.AbsoluteIndex)', [lTreeNode.AbsoluteIndex]), Pointer(lTag));
  // testing delete TreeNode with this Text
  lTag.FTag := 4;
  TreeView1.Items.AddObjectFirst(nil, 'Delete Me!', Pointer(lTag)); // Format('AddFirst_1 = %d (nil)', [-1]));
  lTag.FTag := 5;
  TreeView1.Items.AddObjectFirst(lTreeNode, Format('AddFirst_2 = %d (lTreeNode.AbsoluteIndex)', [lTreeNode.AbsoluteIndex]), Pointer(lTag));
  //
  lTag.FTag := 6;
  TreeView1.Items.AddObject(nil, Format('root_item3 = %d (nil)', [-1]), Pointer(lTag));
  lTag.FTag := 7;
  TreeView1.Items.AddObject(nil, Format('root_item4 = %d (nil)', [-1]), Pointer(lTag));
  // 3 - will be the first (AbsoluteIndex = 0), because it was add later...
  lTag.FTag := 8;
  TreeView1.Items.AddObjectFirst(nil, Format('AddFirst_3 = %d (nil)', [-1]), Pointer(lTag));

  lTag.FTag := 9;
  lTreeNodeChild := TreeView1.Items.AddChildObject(lTreeNode, Format('AddChild_1 in lTreeNode[%d]', [lTreeNode.AbsoluteIndex]), Pointer(lTag));
  lTag.FTag := 10;
  TreeView1.Items.AddChildObjectFirst(lTreeNode, Format('AddChildFirst_1 in lTreeNode[%d]', [lTreeNode.AbsoluteIndex]), Pointer(lTag)); // 1
  lTag.FTag := 11;
  TreeView1.Items.AddChildObject(lTreeNode, Format('Delete Me!', [lTreeNode.AbsoluteIndex]), Pointer(lTag));
  lTag.FTag := 12;
  TreeView1.Items.AddChildObject(lTreeNode, Format('AddChild_3 in lTreeNode[%d]', [lTreeNode.AbsoluteIndex]), Pointer(lTag));
  // 0 - will be the first (AbsoluteIndex = 0), because it was add later...
  lTag.FTag := 13;
  TreeView1.Items.AddChildObjectFirst(lTreeNode, Format('AddChildFirst_2 in lTreeNode[%d]', [lTreeNode.AbsoluteIndex]), Pointer(lTag));
  //
  lTreeNode.Expand(True); // expand childs recursivelly
  // ----------------------
  prcListAllTreeNodes(TreeView1, TreeView1.Items.Count);

end;

end.
[/SHOWTOGROUPS]
 
Последнее редактирование:
Статус
В этой теме нельзя размещать новые ответы.