TOPIC:

unit SerialSelector;

{$mode objfpc}{$H+}

interface

uses
  Classes, LResources, Forms, StdCtrls, PropertyStorage, Controls, Windows, Messages;

type
  { TDeviceNotifier }

  TDeviceNotifier = class
  private
    FOnDeviceArrival: TNotifyEvent;
    FOnDeviceRemoval: TNotifyEvent;
    hRecipient: HWND;
    PMethod: ^TWndMethod;
    FNotificationHandle: Pointer;
    procedure SetOnDeviceArrival(AValue: TNotifyEvent);
    procedure SetOnDeviceRemoval(AValue: TNotifyEvent);
    procedure WndProc(var Msg: TMessage);
    procedure AllocHandle(Method: TWndMethod);
  public
    constructor Create(GUID_DEVINTERFACE : TGUID);
    property OnDeviceArrival: TNotifyEvent read FOnDeviceArrival write SetOnDeviceArrival;
    property OnDeviceRemoval: TNotifyEvent read FOnDeviceRemoval write SetOnDeviceRemoval;
    destructor Destroy; override;
  end;

  { TSerialSelector : Component for select serial port }

  TSerialSelector = class(TCustomComboBox)
  private
    FOnUnavailable: TNotifyEvent;
    NF : TDeviceNotifier;
    procedure Notify;
    procedure UpdateList(Sender : TObject = NIL);
  protected
    procedure Loaded; override;
  public
    constructor Create(TheOwner: TComponent); override;
    destructor Destroy; override;
  published
    property OnUnavailable : TNotifyEvent read FOnUnavailable write FOnUnavailable;

    property Align;
    property Anchors;
    property ArrowKeysTraverseList;
    property AutoSelect;
    property AutoSize;
    property BidiMode;
    property BorderSpacing;
    property BorderStyle;
    property CharCase;
    property Color;
    property Constraints;
    property DoubleBuffered;
    property DragCursor;
    property DragKind;
    property DragMode;
    property DropDownCount;
    property Enabled;
    property Font;
    property OnChange;
    property OnChangeBounds;
    property OnClick;
    property OnCloseUp;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawItem;
    property OnEndDrag;
    property OnDropDown;
    property OnEnter;
    property OnExit;
    property OnGetItems;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMeasureItem;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
    property OnSelect;
    property OnStartDrag;
    property OnUTF8KeyPress;
    property ParentBidiMode;
    property ParentColor;
    property ParentDoubleBuffered;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Text;
    property Visible;
end;

procedure Register;

implementation
uses JwaWinUser, JwaDbt, Registry;

procedure CallbackAllocateHWnd(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam); stdcall;
var
  Msg: TMessage;
  PMethod: ^TWndMethod;
begin
  FillChar(Msg{%H-}, SizeOf(Msg), #0);

  Msg.msg := uMsg;
  Msg.wParam := wParam;
  Msg.lParam := lParam;

  PMethod := {%H-}Pointer(GetWindowLong(ahwnd, GWL_USERDATA));

  if Assigned(PMethod) then PMethod^(Msg);

  Windows.DefWindowProc(ahwnd, uMsg, wParam, lParam);
end;

{ TSerialSelector }

procedure TSerialSelector.Notify;
begin
  if assigned(FOnUnavailable)
     then FOnUnavailable(Self);
end;

procedure TSerialSelector.UpdateList(Sender : TObject = NIL);
var
  L : TStringList;
  S, N : string;
  Reg : TRegistry;
  KI : TRegKeyInfo;
begin
  Reg := TRegistry.Create;
  L := TStringList.Create;
  with Reg do try
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKeyReadOnly('HARDWARE\DEVICEMAP\SERIALCOMM');
    S := Text;
    Reg.GetKeyInfo(KI);
    if KI.NumValues > 0 then GetValueNames(L);
    Clear;
    for N in L do Items.Add(ReadString(N));
    Text := S;
    if S <> Text then Notify;
  finally
    L.Free;
    Free;
  end;
end;

procedure TSerialSelector.Loaded;
begin
  inherited Loaded;
  UpdateList;
end;

constructor TSerialSelector.Create(TheOwner: TComponent);
const
  GUID_DEVINTERFACE_COMPORT  : TGUID = '{86E0D1E0-8089-11D0-9CE4-08003E301F73}';
begin
  inherited Create(TheOwner);
  NF := TDeviceNotifier.Create(GUID_DEVINTERFACE_COMPORT);
  NF.OnDeviceArrival := @UpdateList;
  NF.OnDeviceRemoval := @UpdateList;
  Sorted := true;
  Style := csDropDownList;
end;

destructor TSerialSelector.Destroy;
begin
  NF.Free;
  inherited Destroy;
end;

constructor TDeviceNotifier.Create(GUID_DEVINTERFACE : TGUID);
var
  NotificationFilter: TDevBroadcastDeviceInterface;
begin
  inherited Create;
  AllocHandle(@WndProc);

  ZeroMemory(@NotificationFilter, SizeOf(NotificationFilter));
  NotificationFilter.dbcc_size := SizeOf(NotificationFilter);
  NotificationFilter.dbcc_devicetype := DBT_DEVTYP_DEVICEINTERFACE;
  NotificationFilter.dbcc_classguid  := GUID_DEVINTERFACE;
  //register the device class to monitor
  FNotificationHandle := RegisterDeviceNotification(hRecipient, @NotificationFilter, DEVICE_NOTIFY_WINDOW_HANDLE);
end;

procedure TDeviceNotifier.WndProc(var Msg: TMessage);
var
  Dbi: PDevBroadcastDeviceInterface;
begin
  with Msg do
  if (Msg = WM_DEVICECHANGE) and ((WParam = DBT_DEVICEARRIVAL) or (WParam = DBT_DEVICEREMOVECOMPLETE)) then
  try
    Dbi := PDevBroadcastDeviceInterface(LParam);
    if Dbi^.dbcc_devicetype = DBT_DEVTYP_DEVICEINTERFACE then
    begin
      if WParam = DBT_DEVICEARRIVAL then
      begin
        if Assigned(FOnDeviceArrival) then
          FOnDeviceArrival(Self);
      end
      else
      if WParam = DBT_DEVICEREMOVECOMPLETE then
      begin
        if Assigned(FOnDeviceRemoval) then
          FOnDeviceRemoval(Self);
      end;
    end;
  except
    Result := DefWindowProc(hRecipient, Msg, WParam, LParam);
  end
  else
    Result := DefWindowProc(hRecipient, Msg, WParam, LParam);
end;

procedure TDeviceNotifier.SetOnDeviceArrival(AValue: TNotifyEvent);
begin
  if FOnDeviceArrival = AValue then Exit;
  FOnDeviceArrival := AValue;
end;

procedure TDeviceNotifier.SetOnDeviceRemoval(AValue: TNotifyEvent);
begin
  if FOnDeviceRemoval = AValue then Exit;
  FOnDeviceRemoval := AValue;
end;

procedure TDeviceNotifier.AllocHandle(Method: TWndMethod);
var
  LR : LongWord;
begin
  hRecipient := Windows.CreateWindow(PChar('STATIC'), '', WS_OVERLAPPED, 0, 0, 0, 0, HWND_MESSAGE , 0, MainInstance, nil);
  if Assigned(Method) then
  begin
    Getmem(PMethod, SizeOf(TMethod));
    PMethod^ := Method;
    windows.SetLastError(0);
    LR := SetWindowLongPtr(hRecipient, GWL_USERDATA, {%H-}PtrInt(PMethod));
    LR := GetLastError;
  end;

  windows.SetLastError(0);
  LR := SetWindowLongPtr(hRecipient, GWL_WNDPROC, {%H-}PtrInt(@CallbackAllocateHWnd));
  LR := GetLastError;
end;

destructor TDeviceNotifier.Destroy;
begin
  UnregisterDeviceNotification(FNotificationHandle);
  DestroyWindow(hRecipient);
  Freemem(PMethod);
  inherited;
end;


procedure Register;
begin
  {$I serialselector_icon.ctrs}
  RegisterComponents('ARV Tools',[TSerialSelector]);
end;

end.