shineworld

February 15, 2022

I'm converting a complex Python PySimpleGUI based program to Python using delphivcl module.

In my initial test, the gained speed on UI things sees delphivcl as a very winner.

But I need to add some missing features in delphivcl controls as well as the possibility to modify

an Image (TImage) content sending it as an array of bitmap (NumPy arrays) instead to have to create

a file.bmp and then load it with Image.Picture.LoadFromFile.

Also, I need to add OnMouseDown/OnMouseUp in buttons.

Gitting delphivcl, or delphifmx, I was not able to find the delphi building project, only the final files.

Where I can find sources and projects to make delphivcl module and so to add new features?

February 10, 2022

GetIt is a very useful tool, just a click to install, but if you want to be always on the piece and aligned to the latest changes is better to work directly with sources in github.

February 8, 2022

I have not yet found a fast way to load TImage contents starting from a NumPy array...

this method is enough fast BUT require a file support (at 30FPS SSD will suffer a lot):

        # gets and shows frame image storing it in a support file
        bmp_image = cv2.imencode('.bmp', frame)[1].tobytes()
        stream = BytesIO(bmp_image)
        with open("f:\output_a.bmp", "wb") as f:
            f.write(stream.getbuffer())
            f.close()
        self.imgFrameI.Picture.LoadFromFile("f:\output_a.bmp")

this method access to TImage canvas but is VERY SLOW:

        self.imgFrameI.Picture.Bitmap.SetSize(640, 480)
        canvas = self.imgFrameI.Picture.Bitmap.Canvas
        rgb_im = PIL_Image.fromarray(frame)
        for x in range(640):
            for y in range(480):
                b, g, r = rgb_im.getpixel((x, y))
                rgb = b * 65536 + g * 256 + r
                canvas.SetPixel(x, y, rgb)

There is some other way to set Picture of a Image() object from a image array ?

February 2, 2022

I was not able to update image content directly from data in memory, but only

passing from a support file:

    def __on_timer_update(self, sender):
        # gets frame
        frame = cvc.video_capture_get_frame()
        bmp_image = cv2.imencode('.bmp', frame)[1].tobytes()

        # shows frame image storing it in a support file
        stream = BytesIO(bmp_image)
        with open("output.bmp", "wb") as f:
            f.write(stream.getbuffer())
            f.close()
        self.imgFrame.Picture.LoadFromFile("output.bmp")

This works but I would like to avoid working with files because 60 FPS are

dangerous for SSD devices.

There is some other way to assign the image, in this case a BMP to be simple,
directly to an Image() object using python + DelphiVCL library module ?

February 1, 2022

Hi all.

I'm trying to convert a layout from PySimpleGUI to DelphiVCL.

All works fine but I was not able to put an image in an Image() component programmatically.

1] I get a frame from OpenCV VideoCamera cap with:

self.__cap = cv2.VideoCapture(0, cv2.CAP_DSHOW)

ret, frame = self.__cap.read() 2] I convert the frame to a png image with:
png_image = cv2.imencode('.png', frame)[1].tobytes()

Now with PySimpleGUI I just update it with:

view.window['image_1'].update(data=png_image) where image_1 = sg.Image(filename='', key='image_1', size=(640, 480))

With DelphiVCL I've created a image_1 = Image(self) and assigned basic parent and props

but I don't find a way to update the img (an array of bytes with a PNG image inner).

Thank you very much for suggestions.

December 23, 2021

My preferred:

Image32
SynEdit
GLScene

December 16, 2021

The hard thing with a new environment, eg: Sydney vs Alexandria, is to move all 3rd parties libraries (often to re-buy), but overall learn workaround on always present IDE issues.

The time to discover a problem with an IDE and tool-chain and learn the right workarounds to continue to work is a long activity.
Back from new created file project to old, in case of very critical issues are a very waste of time.

December 14, 2021

@pyscripter

I will do it surely!
I'm trying initially to use the tools as they are.

In the second phase, I will try to put my hands on it!

December 14, 2021

Hi, all

I'm trying to use Python extension from Embarcadero:
https://github.com/Embarcadero/DelphiVCL4Python

installed in Python 3.9 (32 bits) with

pip install delphivcl

I was able to assign an OnClick event (in a Button):

        # creates jogs buttons
        btnXM = Button(self)
        btnXM.Parent = pgOne
        btnXM.Caption = 'X-'
        btnXM.Left = 8
        btnXM.Top = 10
        btnXP = Button(self)
        btnXP.Parent = pgOne
        btnXP.Caption = 'X+'
        btnXP.Left = btnXM.Left + btnXM.Width + 8
        btnXP.Top = 10

        def ClickEventHandler(Sender):
            pass

        btnXP.OnClick = self.jogClickEvent

        def MouseDownHandler(Sender, State, Button, X, Y):
            pass

        btnXP.OnMouseDown = MouseDownHandler

but when reaches the btnXP.OnMouseDown Python notice this error:

*** Remote Interpreter Reinitialized ***
Traceback (most recent call last):
  File "D:\x\develop\qem\rosetta_cnc_1\python-scripts\pyipctcpjsonvcl-demo.py", line 249, in <module>
    main()
  File "D:\x\develop\qem\rosetta_cnc_1\python-scripts\pyipctcpjsonvcl-demo.py", line 241, in main
    f = MainForm(Application)
  File "D:\x\develop\qem\rosetta_cnc_1\python-scripts\pyipctcpjsonvcl-demo.py", line 67, in __init__
    btnXP.OnMouseDown = MouseDownHandler
AttributeError: Error in setting property OnMouseDown
Error: No Registered EventHandler for events of type "TMouseEvent

Looking at btnXP dir():

print(btnXP.__dir__())

['__bound__', '__dir__', '__owned__', 'Action', 'AfterConstruction', 'Align', 'AlignDisabled', 'AlignWithMargins', 'Anchors', 'Assign', 'BeforeDestruction', 'BeginDrag', 'BeginInvoke', 'BiDiMode', 'BindMethodsToEvents', 'BoundsRect', 'BringToFront', 'Broadcast', 'Brush', 'Cancel', 'CanFocus', 'Caption', 'CheckNonMainThreadUsage', 'ClassInfo', 'ClassName', 'ClassNameIs', 'ClassParent', 'ClassType', 'CleanupInstance', 'Click', 'ClientHeight', 'ClientOrigin', 'ClientRect', 'ClientToParent', 'ClientToScreen', 'ClientWidth', 'CommandLinkHint', 'ComObject', 'ComponentCount', 'ComponentIndex', 'Components', 'ComponentState', 'ComponentStyle', 'Constraints', 'ContainsControl', 'ControlAtPos', 'ControlCount', 'Controls', 'ControlState', 'ControlStyle', 'Create', 'CreateParented', 'CreateParentedControl', 'CurrentPPI', 'Cursor', 'CustomHint', 'Default', 'DefaultHandler', 'DesignInfo', 'Destroy', 'DestroyComponents', 'Destroying', 'DisableAlign', 'DisabledImageIndex', 'DisabledImageName', 'DisabledImages', 'Dispatch', 'DisposeOf', 'Dock', 'DockClientCount', 'DockDrop', 'DockManager', 'DockOrientation', 'DockSite', 'DoubleBuffered', 'DragCursor', 'DragDrop', 'Dragging', 'DragKind', 'DragMode', 'DrawTextBiDiModeFlags', 'DrawTextBiDiModeFlagsReadingOnly', 'DropDownMenu', 'ElevationRequired', 'EnableAlign', 'Enabled', 'EndDrag', 'EndFunctionInvoke', 'EndInvoke', 'Equals', 'ExecuteAction', 'ExplicitHeight', 'ExplicitLeft', 'ExplicitTop', 'ExplicitWidth', 'FieldAddress', 'FindChildControl', 'FindComponent', 'FlipChildren', 'Floating', 'FloatingDockSiteClass', 'Focused', 'Font', 'Free', 'FreeInstance', 'FreeNotification', 'FreeOnRelease', 'GetChildren', 'GetControlsAlignment', 'GetEnumerator', 'GetHashCode', 'GetInterface', 'GetInterfaceEntry', 'GetInterfaceTable', 'GetNamePath', 'GetParentComponent', 'GetStyleName', 'GetSystemMetrics', 'GetTabControlList', 'GetTabOrderList', 'GetTextBuf', 'GetTextLen', 'Handle', 'HandleAllocated', 'HandleNeeded', 'HasParent', 'Height', 'HelpContext', 'HelpKeyword', 'HelpType', 'Hide', 'Hint', 'HostDockSite', 'HotImageIndex', 'HotImageName', 'ImageAlignment', 'ImageIndex', 'ImageMargins', 'ImageName', 'Images', 'InheritsFrom', 'InitiateAction', 'InitInstance', 'InsertComponent', 'InsertControl', 'InstanceSize', 'Invalidate', 'IsCustomStyleActive', 'IsDrawingLocked', 'IsImplementorOf', 'IsLightStyleColor', 'IsRightToLeft', 'Left', 'LockDrawing', 'LRDockWidth', 'ManualDock', 'ManualFloat', 'Margins', 'MethodAddress', 'MethodName', 'ModalResult', 'MouseInClient', 'MouseWheelHandler', 'Name', 'NewInstance', 'Observers', 'OnClick', 'OnContextPopup', 'OnDragDrop', 'OnDragOver', 'OnDropDownClick', 'OnEndDock', 'OnEndDrag', 'OnEnter', 'OnExit', 'OnGesture', 'OnKeyDown', 'OnKeyPress', 'OnKeyUp', 'OnMouseActivate', 'OnMouseDown', 'OnMouseEnter', 'OnMouseLeave', 'OnMouseMove', 'OnMouseUp', 'OnStartDock', 'OnStartDrag', 'Owner', 'Padding', 'PaintTo', 'Parent', 'ParentBiDiMode', 'ParentCustomHint', 'ParentDoubleBuffered', 'ParentFont', 'ParentShowHint', 'ParentToClient', 'ParentWindow', 'Perform', 'PixelsPerInch', 'PopupMenu', 'PreProcessMessage', 'PressedImageIndex', 'PressedImageName', 'QualifiedClassName', 'Realign', 'RedrawDisabled', 'ReferenceInterface', 'Refresh', 'RemoveComponent', 'RemoveControl', 'RemoveFreeNotification', 'Repaint', 'ReplaceDockedControl', 'SafeCallException', 'ScaleBy', 'ScaleFactor', 'ScaleForPPI', 'ScaleRectSize', 'ScaleValue', 'ScreenToClient', 'ScrollBy', 'SelectedImageIndex', 'SelectedImageName', 'SendToBack', 'SetBounds', 'SetDesignVisible', 'SetFocus', 'SetParentComponent', 'SetProps', 'SetSubComponent', 'SetTextBuf', 'Show', 'ShowHint', 'Showing', 'Style', 'StyleElements', 'StyleName', 'StylusHotImageIndex', 'StylusHotImageName', 'TabOrder', 'TabStop', 'Tag', 'TBDockHeight', 'ToList', 'Top', 'ToString', 'ToTuple', 'Touch', 'UndockHeight', 'UndockWidth', 'UnitName', 'UnitScope', 'UnlockDrawing', 'Update', 'UpdateAction', 'UpdateControlState', 'UseDockManager', 'UseRightToLeftAlignment', 'UseRightToLeftReading', 'UseRightToLeftScrollBar', 'VCLComObject', 'Visible', 'VisibleDockClientCount', 'Width', 'WindowProc', 'WordWrap']

OnMouseDown/Up are exposed....

I'm not able to understand what I've missed...

Thank you in advance for suggestions

December 7, 2021

12 hours ago, Remy Lebeau said:

Though, are you really sure you want to catch an exception at all? You are going to leave the connection in an unstable state. You may as well just let the exception propagate up the call stack uncaught, and let the server catch it and close the connection for you.

I'm not aware of that, I'm an occasional user of Indy classes.

So on TIdTTCPServerContex.Execute is better do not manage exceptions on WriteLn because are correctly managed in TidTCPServer.Execute caller?

To be honest I've got some issues during close application when I do TIdTCPServer.Active := False and TIdTCPServer.Free; with connected clients...
Could be because I catch the exceptions on Execute().... and the caller doesn't manage the right closing states.

I've changed to:

procedure TIPCTCPServerContext.Execute;
type
  TRequestType = ( rqtpCmd, rqtpGet, rqtpSet );
var
  ArgS: string;
  ArgI: Integer;
  Command: string;
  Request: string;
  Response: string;
  JsonValue: TJSONValue;
  RequestType: TRequestType;
begin
  // sets default response
  Response := RES_NULL;

  // extracts request from tcp stack
  Request := Trim(Connection.IOHandler.ReadLn);
  try
    // gets request type
    JSONValue := TJSONObject.ParseJSONValue(Request);
    try
      if not (JSONValue is TJSONObject) then Exit;
      while True do
      begin
        if JSONValue.TryGetValue(REQ_CMD, Command) then
        begin
          RequestType := rqtpCmd;
          Break;
        end;
        if JSONValue.TryGetValue(REQ_GET, Command) then
        begin
          RequestType := rqtpGet;
          Break;
        end;
        if JSONValue.TryGetValue(REQ_SET, Command) then
        begin
          RequestType := rqtpSet;
          Break;
        end;
        Exit;
      end;

      // evaluates request type
      case RequestType of
        rqtpCmd:
        begin
          if Command = 'cnc.homing' then
          begin
            if not JSONValue.TryGetValue<Integer>('["axes.mask"]', ArgI) then Exit;
            Response := DoCmdCNCHoming(ArgI);
          end
          else if Command = 'cnc.mdi.command' then
          begin
            if not JSONValue.TryGetValue('command', ArgS) then Exit;
            Response := DoCmdCNCMDICommand(ArgS);
          end
          else if Command = 'cnc.pause' then
            Response := DoCmdCNCPause
          else if Command = 'cnc.resume.after.pause' then
            Response := DoCmdCNCResumeAfterPause
          else if Command = 'cnc.resume.after.stop' then
          begin
            if JSONValue.TryGetValue<Integer>('line', ArgI) then
              Response := DoCmdCNCResumeAfterStop(ArgI)
            else
              Response := DoCmdCNCResumeAfterStop(0);
          end
          else if Command = 'cnc.start' then
          begin
            if JSONValue.TryGetValue<Integer>('line', ArgI) then
              Response := DoCmdCNCStart(ArgI)
            else
              Response := DoCmdCNCStart(0);
          end
          else if Command = 'cnc.stop' then
            Response := DoCmdCNCStop
          else if Command = 'program.analysis' then
          begin
            if JSONValue.TryGetValue('mode', ArgS) then
              Response := DoCmdProgramAnalysis(ArgS)
            else
              Response := DoCmdProgramAnalysis('');
          end
          else if Command = 'program.analysis.abort' then
            Response := DoCmdProgramAnalysisAbort
          else if Command = 'program.gcode.add.text' then
          begin
            if not JSONValue.TryGetValue('text', ArgS) then Exit;
            Response := DoCmdProgramGCodeAddText(ArgS);
          end
          else if Command = 'program.gcode.clear' then
            Response := DoCmdProgramGCodeClear
          else if Command = 'program.gcode.set.text' then
          begin
            if not JSONValue.TryGetValue('text', ArgS) then Exit;
            Response := DoCmdProgramGCodeSetText(ArgS);
          end
          else if Command = 'program.load' then
          begin
            if not JSONValue.TryGetValue('name', ArgS) then Exit;
            Response := DoCmdProgramLoad(ArgS);
          end
          else if Command = 'program.new' then
            Response := DoCmdProgramNew
          else if Command = 'program.save' then
          begin
            if JSONValue.TryGetValue('name', ArgS) then
              Response := DoCmdProgramSave(ArgS)
            else
              Response := DoCmdProgramSave('')
          end
          else
            Exit;
        end;
        rqtpGet:
        begin
          if Command = 'axes.info' then
            Response := DoGetAxesInfo
          else if Command = 'cnc.info' then
            Response := DoGetCNCInfo
          else if Command = 'compile.info' then
            Response := DoGetCompileInfo
          else if Command = 'system.info' then
            Response := DoGetSystemInfo
          else
            Exit;
        end;
        rqtpSet:
        begin
          //##
        end;
      end;
    finally
      JSONValue.Free;
    end;
  finally
    Connection.IOHandler.WriteLn(Response);
  end;
end;

Should be more right now...

December 4, 2021

Yes Remy, I've made

procedure TIPCTCPServerContext.Execute;
type
  TRequestType = ( rqtpCmd, rqtpGet, rqtpSet );
var
  ArgS: string;
  ArgI: Integer;
  Command: string;
  Request: string;
  Response: string;
  JsonValue: TJSONValue;
  RequestType: TRequestType;
begin
  try
    // sets default response
    Response := RES_NULL;

    // extracts request from tcp stack
    Request := Trim(Connection.IOHandler.ReadLn);

    // gets request type
    JSONValue := TJSONObject.ParseJSONValue(Request);
    try
      if not (JSONValue is TJSONObject) then AbortFast;
      while True do
      begin
        if JSONValue.TryGetValue(REQ_CMD, Command) then
        begin
          RequestType := rqtpCmd;
          Break;
        end;
        if JSONValue.TryGetValue(REQ_GET, Command) then
        begin
          RequestType := rqtpGet;
          Break;
        end;
        if JSONValue.TryGetValue(REQ_SET, Command) then
        begin
          RequestType := rqtpSet;
          Break;
        end;
        AbortFast;
      end;

      // evaluates request type
      case RequestType of
        rqtpCmd:
        begin
          if Command = 'cnc.homing' then
          begin
            if not JSONValue.TryGetValue<Integer>('["axes.mask"]', ArgI) then AbortFast;
            Response := DoCmdCNCHoming(ArgI);
          end
          else if Command = 'cnc.mdi.command' then
          begin
            if not JSONValue.TryGetValue('command', ArgS) then AbortFast;
            Response := DoCmdCNCMDICommand(ArgS);
          end
          else if Command = 'cnc.pause' then
            Response := DoCmdCNCPause
          else if Command = 'cnc.resume.after.pause' then
            Response := DoCmdCNCResumeAfterPause
          else if Command = 'cnc.resume.after.stop' then
          begin
            if JSONValue.TryGetValue<Integer>('line', ArgI) then
              Response := DoCmdCNCResumeAfterStop(ArgI)
            else
              Response := DoCmdCNCResumeAfterStop(0);
          end
          else if Command = 'cnc.start' then
          begin
            if JSONValue.TryGetValue<Integer>('line', ArgI) then
              Response := DoCmdCNCStart(ArgI)
            else
              Response := DoCmdCNCStart(0);
          end
          else if Command = 'cnc.stop' then
            Response := DoCmdCNCStop
          else if Command = 'program.analysis' then
          begin
            if JSONValue.TryGetValue('mode', ArgS) then
              Response := DoCmdProgramAnalysis(ArgS)
            else
              Response := DoCmdProgramAnalysis('');
          end
          else if Command = 'program.analysis.abort' then
            Response := DoCmdProgramAnalysisAbort
          else if Command = 'program.gcode.add.text' then
          begin
            if not JSONValue.TryGetValue('text', ArgS) then AbortFast;
            Response := DoCmdProgramGCodeAddText(ArgS);
          end
          else if Command = 'program.gcode.clear' then
            Response := DoCmdProgramGCodeClear
          else if Command = 'program.gcode.set.text' then
          begin
            if not JSONValue.TryGetValue('text', ArgS) then AbortFast;
            Response := DoCmdProgramGCodeSetText(ArgS);
          end
          else if Command = 'program.load' then
          begin
            if not JSONValue.TryGetValue('name', ArgS) then AbortFast;
            Response := DoCmdProgramLoad(ArgS);
          end
          else if Command = 'program.new' then
            Response := DoCmdProgramNew
          else if Command = 'program.save' then
          begin
            if JSONValue.TryGetValue('name', ArgS) then
              Response := DoCmdProgramSave(ArgS)
            else
              Response := DoCmdProgramSave('')
          end
          else
            AbortFast;
        end;
        rqtpGet:
        begin
          if Command = 'system.info' then
            Response := DoGetSystemInfo
          else if Command = 'axes.info' then
            Response := DoGetAxesInfo
          else
            AbortFast;
        end;
        rqtpSet:
        begin
          //##
        end;
      end;
    finally
      JSONValue.Free;
    end;

    // sends response as json contents
    Connection.IOHandler.WriteLn(Response);
  except
    try Connection.IOHandler.WriteLn(Response) except end;
  end;
end;

December 3, 2021

Works perfectly !!!
The only issue is on Delphi LSP which seems unable to elaborate pascal code for anonymous procedures on TTask( proc or TThread.Synchronize( Self, proc..,

December 3, 2021

Same of mine:

December 3, 2021

WOW compile but IDE signs as error.

Perhaps is a bug in LSP...

December 3, 2021

Hi all,

I'm trying to use TTask to perform some parallel code with Sydney 10.4.1 looking at the sample code in Help System,

so it should be supported by 10.4.1:

but I've got always the error:
[dcc32 Error] osIPCTCPServerContext.pas(423): E2250 There is no overloaded version of 'Create' that can be called with these arguments

Have you any idea about it?

Thank you in advance for replies.

December 2, 2021

You are RIGHT !!!

Very sorry for this typo....

December 2, 2021

Hi all.

I'm new to JSON frameworks and I'm getting lost in a spoonful of water.

In the Sydney help I've found this code:

JSONValue := TJSONObject.ParseJSONValue('{"colors":[{"name":"red", "hex":"#f00"}]}');

Memo1.Lines.Add('READER:');
if JSONValue is TJSONArray then
  //... 
else if JSONVAlue is TJSONObject then
  Memo1.Lines.Add('colors');
  Memo1.Lines.Add('name: '+ JSONValue.GetValue<string>('colors[0].name'));
  Memo1.Lines.Add('hex: '+ JSONValue.GetValue<string>('colors[0].hex'));

Now this works fine but I need to read a client request so formatted:

var
      Text: string;
      Command: string;
      JsonValue: TJSONValue;
      JsonValueArg: TJSONValue;
begin
      // parse json
      JSONValue := TJSONObject.ParseJSONValue('{"cmd":"program.add.text", "txt":"for I := 0 to 100 do"}');
      if not (JSONValue is TJSONObject) then Exit;

      // gets command type (in Command I've found the "cmd" value "program.add.text". ALL RIGHT!!!)
      if JSONValue.TryGetValue('cmd', Command) then Exit;

      // gets command argument txt (does not found the "txt" value and program EXITS!!!)
      if JSONValue.TryGetValue('txt', Text) then Exit;

	//...

I can't change the JSON request string to contain an array as well as in the Embarcardero sample because reach from a customer program and I've checked with only JSON validator and seem to be fine.

What was I've mistaken?

Thank you in advance for your replies.

November 29, 2021

In a project file usually, I add that:

    // checks if application is already running
    AppplicationID := '{BFA11B69-B59C-40BA-BABB-724F2BF3AFE4}';
    RunOnceMutex := CreateMutex(nil, True, @ApplicationID[1]);
    if RunOnceMutex <> 0 then
    begin
      if GetLastError = ERROR_ALREADY_EXISTS then
      begin
        ShowErrorMessage
        (
          _('Application already running'),
          _('Press OK button to quit application'),
          _('Instance of this application is already running !'),
          _('For each computer, or virtual machine, is allowed to start a single instance of the Control Software. ' +
            'If you see this message it means that an application instance is already loaded and running.')
        );
        CloseHandle(RunOnceMutex);
        Halt;
      end
    end;

Take care to create a different UUID for every singleton application.

You can fastly create a new UUID pressing CTRL + SHIFT + G in Delphi IDE.

Library to get user, computer info · November 26, 2021

You can get any info with WMI support.

WMI covers a very very incredible set of infos.

This is a sample that I use to recover some system info.

unit osSystemInfo;

interface

type
  TSystemInfoMode = ( simdCompact, simdFull );

  TMotherBoardInfo = ( mbiSerialNumber, mbiManufacturer, mbiProduct, mbiModel );
  TMotherBoardInfos = set of TMotherBoardInfo;

  TOSInfo = ( osiBuildNumber, osiBuildType, osiManufacturer, osiName, osiSerialNumber, osiVersion );
  TOSInfos = set of TOSInfo;

  TProcessorInfo = ( priDescription, priManufacturer, priName, priProcessorId, priUniqueId, priSystemName );
  TProcessorInfos = set of TProcessorInfo;

type
  TSystemInfo = class
  private
    FBuffer: AnsiString;
    FMotherBoardInfos: TMotherBoardInfos;
    FNeedUninitialize: Boolean;
    FOSInfos: TOSInfos;
    FProcessorInfos: TProcessorInfos;
  private
    procedure Clear;
  public
    function GenerateInfo(Mode: TSystemInfoMode = simdCompact): Boolean;
  public
    property Buffer: AnsiString read FBuffer;
    property MotherBoardInfos: TMotherBoardInfos read FMotherBoardInfos write FMotherBoardInfos;
    property OSInfos: TOSInfos read FOSInfos write FOSInfos;
    property ProcessorInfos: TProcessorInfos read FProcessorInfos write FProcessorInfos;
  public
    constructor Create;
    destructor Destroy; override;
  end;

implementation

uses
  ComObj,
  ActiveX,
  SysUtils,
  Variants,

  osExceptionUtils;

var
  MotherBoardInfoText: array[TMotherBoardInfo] of AnsiString = ( 'SerialNumber', 'Manufacturer', 'Product', 'Model' );
  OSInfoText: array [TOSInfo] of AnsiString = ( 'BuildNumber', 'BuildType', 'Manufacturer', 'Name', 'SerialNumber', 'Version' );
  ProcessorInfoText: array [TProcessorInfo] of AnsiString = ( 'Description', 'Manufacturer', 'Name', 'ProcessorId', 'UniqueId', 'SystemName' );

procedure TSystemInfo.Clear;
begin
  FBuffer := '';
end;

constructor TSystemInfo.Create;
begin
  inherited;

  FBuffer := '';
  FMotherBoardInfos := [];
  FNeedUninitialize := False;
  FOSInfos :=  [];
  FProcessorInfos := [];

  FNeedUninitialize := CoInitialize(nil) = S_OK;
end;

destructor TSystemInfo.Destroy;
begin
  if FNeedUninitialize then
    CoUninitialize;

  inherited;
end;

function TSystemInfo.GenerateInfo(Mode: TSystemInfoMode): Boolean;
var
  S: AnsiString;
  OSInfo: TOSInfo;
  IValue: LongWord;
  OSInfos: TOSInfos;
  OEnum: IEnumvariant;
  OWmiObject: OLEVariant;
  ObjWMIService: OLEVariant;
  ObjSWbemLocator: OLEVariant;
  objWbemObjectSet: OLEVariant;
  ProcessorInfo: TProcessorInfo;
  ProcessorInfos: TProcessorInfos;
  MotherBoardInfo: TMotherBoardInfo;
  MotherBoardInfos: TMotherBoardInfos;

  function VarArrayToStr(const vArray: Variant): AnsiString;

    function _VarToStr(const V: Variant): AnsiString;
    var
      Vt: Integer;
    begin
      Vt := VarType(V);
      case Vt of
        varSmallint,
        varInteger  : Result := AnsiString(IntToStr(Integer(V)));
        varSingle,
        varDouble,
        varCurrency : Result := AnsiString(FloatToStr(Double(V)));
        varDate     : Result := AnsiString(VarToStr(V));
        varOleStr   : Result := AnsiString(WideString(V));
        varBoolean  : Result := AnsiString(VarToStr(V));
        varVariant  : Result := AnsiString(VarToStr(Variant(V)));
        varByte     : Result := AnsiChar(Byte(V));
        varString   : Result := AnsiString(V);
        varArray    : Result := VarArrayToStr(Variant(V));
      end;
    end;

  var
    I: Integer;
  begin
    Result := '[';
    if (VarType(vArray) and VarArray) = 0 then
       Result := _VarToStr(vArray)
    else
    begin
      for I := VarArrayLowBound(vArray, 1) to VarArrayHighBound(vArray, 1) do
      begin
        if I = VarArrayLowBound(vArray, 1) then
          Result := Result + _VarToStr(vArray[I])
        else
          Result := Result + '|' + _VarToStr(vArray[I]);
      end;
    end;
    Result:=Result + ']';
  end;

  function VarStrNull(const V: OleVariant): AnsiString;
  begin
    Result := '';
    if not VarIsNull(V) then
    begin
      if VarIsArray(V) then
         Result := VarArrayToStr(V)
      else
      Result := AnsiString(VarToStr(V));
    end;
  end;

begin
  Clear;
  try
    ObjSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
    if VarIsNull(ObjSWbemLocator) then AbortFast;
    ObjWMIService := objSWbemLocator.ConnectServer('localhost','root\cimv2', '','');
    if VarIsNull(ObjWMIService) then AbortFast;

    if FMotherBoardInfos <> [] then
    begin
      MotherBoardInfos := FMotherBoardInfos;
      ObjWbemObjectSet := objWMIService.ExecQuery('SELECT * FROM Win32_BaseBoard', 'WQL', 0);
      OEnum := IUnknown(ObjWbemObjectSet._NewEnum) as IEnumVariant;
      while OEnum.Next(1, OWmiObject, IValue) = 0 do
      begin
        if MotherBoardInfos = [] then Break;
        for MotherBoardInfo := Low(TMotherBoardInfo) to High(TMotherBoardInfo) do
        begin
          if MotherBoardInfo in FMotherBoardInfos then
          begin
            S := VarStrNull(OWmiObject.Properties_.Item(MotherBoardInfoText[MotherBoardInfo]).Value);
            Exclude(MotherBoardInfos, MotherBoardInfo);
            case Mode of
              simdCompact:
                FBuffer := FBuffer + S;
              simdFull:
                FBuffer := FBuffer + MotherBoardInfoText[MotherBoardInfo] + ' = ' + S + #13#10;
            end;
          end;
        end;
        OWmiObject := Unassigned;
      end;
    end;

    if FOSInfos <> [] then
    begin
      OSInfos := FOSInfos;
      ObjWbemObjectSet := objWMIService.ExecQuery('SELECT * FROM Win32_OperatingSystem', 'WQL', 0);
      OEnum := IUnknown(ObjWbemObjectSet._NewEnum) as IEnumVariant;
      while OEnum.Next(1, OWmiObject, IValue) = 0 do
      begin
        if OSInfos = [] then Break;
        for OSInfo := Low(TOSInfo) to High(TOSInfo) do
        begin
          if OSInfo in OSInfos then
          begin
            S := VarStrNull(OWmiObject.Properties_.Item(OSInfoText[OSInfo]).Value);
            Exclude(OSInfos, OSInfo);
            case Mode of
              simdCompact:
                FBuffer := FBuffer + S;
              simdFull:
                FBuffer := FBuffer + OSInfoText[OSInfo] + ' = ' + S + #13#10;
            end;
          end;
        end;
        OWmiObject := Unassigned;
      end;
    end;

    if FProcessorInfos <> [] then
    begin
      ProcessorInfos := FProcessorInfos;
      ObjWbemObjectSet := objWMIService.ExecQuery('SELECT * FROM Win32_Processor', 'WQL', 0);
      OEnum := IUnknown(ObjWbemObjectSet._NewEnum) as IEnumVariant;
      while OEnum.Next(1, OWmiObject, IValue) = 0 do
      begin
        if ProcessorInfos = [] then Break;
        for ProcessorInfo := Low(TProcessorInfo) to High(TProcessorInfo) do
        begin
          if ProcessorInfo in ProcessorInfos then
          begin
            S := VarStrNull(OWmiObject.Properties_.Item(ProcessorInfoText[ProcessorInfo]).Value);
            Exclude(ProcessorInfos, ProcessorInfo);
            case Mode of
              simdCompact:
                FBuffer := FBuffer + S;
              simdFull:
                FBuffer := FBuffer + ProcessorInfoText[ProcessorInfo] + ' = ' + S + #13#10;
            end;
          end;
        end;
        OWmiObject := Unassigned;
      end;
    end;

    Result := True;
  except
    Clear;
    Result := False;
  end;
end;

end.

There is also a WMI Delphi Code Generator in which you can brose the interesting data and it creates code for you:

https://github.com/RRUZ/wmi-delphi-code-creator

November 24, 2021

I will try surely!
Thank you again.
Python extension and support on our products were strong requirements from customers.
Happy to know how simple is to do with py4d.

November 23, 2021

Hi all.

I'm trying to create a Python Extension Module with Delphi Sydney.

I'm adding an IPC Engine Client to access to one or more IPC Engine Server (either based on Windows Messages).

It works and is very a good tool.

I've only a question about the resulting python class that does not have a list of properties/methods, not in all cases.

Looking at xxx.__dir__ I can get the list of available methods:

But if I use the code completion of PyScripter only base TPyDelphiPersistent are available:

Strangely if I create a pre-made istance TPyIPCEngineClient object and I add it to the module as SetVar('myIPC', xxxx, xxx) all TPyIPCEngineClient

are showed.

What I'm mistaking ?

Thank you in advance for replies.

pycncipc1.zip

October 26, 2021

Hi all.

Some days ago I've installed the CnWizards_1.2.0.1035 to try the remove unused units for uses sections.

Saw that it does not work as aspected I've uninstalled the software.

After this, the right mouse click mouse disappears and at now only the following pop-up appears:

How to restore original popup with Evaluate, etc etc?

October 22, 2021

Tried Peganza Analyzer Lite and that is what I need 🙂

October 22, 2021

Hi all,

there is a fast way to identify and so remove the unused uses units ?
During the development process, often, I add the required uses to compile, but after months of development, some units could become unused

and I would like to remove them.

At moment, I need to comment one by one and check if the compiler raises an error for the missing unit.

Thank you in advance for reply!

October 18, 2021

In the end, I've solved placing two external TScrollbars (TAdvSmoothScroolbars from TMS), they permit

a deep control of colors and removing Windows SCROLLBAR created by TSynEdit.

- The SynEdit.ScrollBars := ssNone;

- The SynEdit.UpdateScrollbars from private to protected and of dynamic type.

- A helper class in my editor frame class:

unit osGCodeEditorFrame;

interface

uses
  ...
type
  TGCodeEditor = class(SynEdit.TSynEdit)
  private
    procedure EditorVBarPositionChanged(Sender: TObject; Position: Integer);
    procedure EditorHBarPositionChanged(Sender: TObject; Position: Integer);
  protected
    procedure UpdateScrollBars; override;
  private
    FInUpdateScrollBars: Boolean;
  public
    EditorHBar: TAdvSmoothScrollBar;
    EditorVBar: TAdvSmoothScrollBar;
  end;
  ...
  ...

  // creates and sets gcode editor
  FGCodeEditor := TSynEdit.Create(Self);
  FGCodeEditor.Parent := Self;
  FGCodeEditor.Align := alClient;
  FGCodeEditor.Visible := True;
  FGCodeEditor.ScrollBars := ssNone;

  // creates and sets gcode editor horizontal scroll bar
  FGCodeEditor.EditorHBar := TAdvSmoothScrollBar.Create(Self);
  FGCodeEditor.EditorHBar.Parent := Self;
  FGCodeEditor.EditorHBar.Align := alBottom;
  FGCodeEditor.EditorHBar.Kind := sbHorizontal;
  FGCodeEditor.EditorHBar.OnPositionChanged := FGCodeEditor.EditorHBarPositionChanged;

  // creates and sets gcode editor vertical scroll bar
  FGCodeEditor.EditorVBar := TAdvSmoothScrollBar.Create(Self);
  FGCodeEditor.EditorVBar.Parent := Self;
  FGCodeEditor.EditorVBar.Align := alRight;
  FGCodeEditor.EditorVBar.Kind := sbVertical;
  FGCodeEditor.EditorVBar.OnPositionChanged := FGCodeEditor.EditorVBarPositionChanged;

  ...

{ TGCodeEditor }

procedure TGCodeEditor.EditorHBarPositionChanged(Sender: TObject; Position: Integer);
begin
  if FInUpdateScrollBars then Exit;
  LeftChar := EditorHBar.Position;
end;

procedure TGCodeEditor.EditorVBarPositionChanged(Sender: TObject; Position: Integer);
begin
  if FInUpdateScrollBars then Exit;
  TopLine := EditorVBar.Position;
end;

procedure TGCodeEditor.UpdateScrollBars;
 var
  MaxScroll: Integer;
  ScrollInfo: TScrollInfo;
begin
  inherited;

  // checks if standard scroll bars enabled
  if ScrollBars <> ssNone then Exit;

  // check if custom scroll bars enabled
  if (EditorVBar = nil) or (EditorHBar = nil) then Exit;
  FInUpdateScrollBars := True;
  try
    // evaluates for custom horizontal scrollbar
    if EditorHBar <> nil then
    begin
      MaxScroll := Max(TSynEditStringList(Lines).LengthOfLongestLine, 1);
      ScrollInfo.nMin := 1;
      ScrollInfo.nMax := MaxScroll;
      ScrollInfo.nPage := CharsInWindow;
      ScrollInfo.nPos := LeftChar;
      EditorHBar.Min := ScrollInfo.nMin;
      EditorHBar.Max := ScrollInfo.nMax;
      EditorHBar.PageSize := ScrollInfo.nPage;
      EditorHBar.Position := ScrollInfo.nPos;
      EditorHBar.Visible := ScrollInfo.nMax > CharsInWindow;
    end
    else
      EditorHBar.Visible := False;

    // evaluates for custom vertical scrollbar
    if EditorVBar <> nil then
    begin
      MaxScroll := DisplayLineCount;
      ScrollInfo.nMin := 1;
      ScrollInfo.nMax := Max(1, MaxScroll);
      ScrollInfo.nPage := LinesInWindow;
      ScrollInfo.nPos := TopLine;
      EditorVBar.Min := ScrollInfo.nMin;
      EditorVBar.Max := ScrollInfo.nMax;
      EditorVBar.PageSize := ScrollInfo.nPage;
      EditorVBar.Position := ScrollInfo.nPos;
      EditorVBar.Visible := ScrollInfo.nMax > LinesInWindow;
    end
    else
      EditorVBar.Visible := False;
  finally
    FInUpdateScrollBars := False;
  end;
end;

In this way is possible to use standard scrollbars or custom and use the already available and called in TSynEdit.UpdateScrollbars,

which does nothing is ScrollBars = ssNone to manage update of external custom scrollbars.

Works perfectly:

Sign In

shineworld

Content Count

Joined

Last visited

Days Won

Content Type

Profiles

Forums

Calendar

Posts posted by shineworld

python delphivcl development

SynEdit preferred version?

Place image in a TImage

Place image in a TImage

Place image in a TImage

List of most popular UI components for VCL

Delphi 11, migrate or wait

OnMouseDown/Up events

OnMouseDown/Up events

Simple JSON parsing

Simple JSON parsing

TTask on Sydeny 10.4.1

TTask on Sydeny 10.4.1

TTask on Sydeny 10.4.1

TTask on Sydeny 10.4.1

Simple JSON parsing

Simple JSON parsing

How to Prevent Multiple Instance Application Running.

Library to get user, computer info

Python4Delphi module and Wrapping VCL classes

Python4Delphi module and Wrapping VCL classes

Righ mouse click corrupted after CnWizards_1.2.0.1035

Found and remove unused uses units

Found and remove unused uses units

Change Scroll bar color

Browse

Activity