jvcharmap.pas

East make Tray Icon in delphi

    procedure SetCharacter(const Value: WideChar);
    {$IFDEF VCL}
    procedure FormWindowProc(var Msg: TMessage);
    procedure HookWndProc;
    procedure UnhookWndProc;
    {$ENDIF VCL}
    procedure UpdateShadow;
    procedure SetShowShadow(const Value: Boolean);
    procedure SetShadowSize(const Value: Integer);
  protected
    procedure Paint; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    {$IFDEF VCL}
    procedure CreateParams(var Params: TCreateParams); override;
    procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
    {$ENDIF VCL}
    procedure FocusSet(PrevWnd: HWND); override;
    procedure GetDlgCode(var Code: TDlgCodes); override;
    procedure VisibleChanged; override;
    procedure FontChanged; override;

    {$IFDEF VCL}
    procedure CreateHandle; override;
    procedure WMWindowPosChanged(var Msg: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
    {$ENDIF VCL}
    {$IFDEF VisualCLX}
    procedure BoundsChanged; override;
    {$ENDIF VisualCLX}
    procedure SetParent({$IFDEF VisualCLX} const {$ENDIF} AParent: TWinControl); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Character: WideChar read FCharacter write SetCharacter;
    property ShowShadow: Boolean read FShowShadow write SetShowShadow default True;
    property ShadowSize: Integer read FShadowSize write SetShadowSize;
  end;

procedure WideDrawText(Canvas: TCanvas; const Text: WideString; ARect: TRect;
  uFormat: Cardinal);
begin
  // (p3) TCanvasAccessProtected bit stolen from Troy Wolbrink's TNT controls (not that it makes any difference AFAICS)
  with TCanvasAccessProtected(Canvas) do
  begin
    Changing;
    RequiredState([csHandleValid, csFontValid, csBrushValid]);
    {$IFDEF VCL}
    if CanvasOrientation = coRightToLeft then
      Inc(uFormat, DT_RTLREADING);
    {$ENDIF VCL}
    DrawTextW(Handle, PWideChar(Text), Length(Text), ARect, uFormat);
    Changed;
  end;
end;

{$IFDEF MSWINDOWS}

//=== { TShadowWindow } ======================================================

type
  TDynamicSetLayeredWindowAttributes = function(HWnd: THandle; crKey: COLORREF; bAlpha: Byte; dwFlags: DWORD): Boolean; stdcall;

{$IFNDEF COMPILER6_UP}
const
  {$EXTERNALSYM WS_EX_LAYERED}
  WS_EX_LAYERED = $00080000;
  {$EXTERNALSYM LWA_ALPHA}
  LWA_ALPHA = $00000002;
{$ENDIF !COMPILER6_UP}

constructor TShadowWindow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csFixedHeight, csFixedWidth, csNoDesignVisible, csNoStdEvents];
  Color := clBlack;
  Visible := False;
end;

{$IFDEF VisualCLX}
{$DEFINE NeedSetLayer}
{$ENDIF VisualCLX}
{$IFNDEF COMPILER6_UP}
{$DEFINE NeedSetLayer}
{$ENDIF !COMPILER6_UP}

{$IFDEF VCL}
procedure TShadowWindow.CreateHandle;
{$ENDIF VCL}
{$IFDEF VisualCLX}
procedure TShadowWindow.InitWidget;
{$ENDIF VisualCLX}
var
  {$IFDEF NeedSetLayer}
  Wnd: Windows.HWND;
  {$ENDIF NeedSetLayer}
  DynamicSetLayeredWindowAttributes: TDynamicSetLayeredWindowAttributes;

  procedure InitProcs;
  const
    sUser32 = 'User32.dll';
  var
    ModH: HMODULE;
  begin
    ModH := GetModuleHandle(sUser32);
    if ModH <> 0 then
       @DynamicSetLayeredWindowAttributes := GetProcAddress(ModH, 'SetLayeredWindowAttributes')
    else
      @DynamicSetLayeredWindowAttributes := nil;
  end;

begin
  {$IFDEF VCL}
  inherited CreateHandle;
  {$ENDIF VCL}
  {$IFDEF VisualCLX}
  inherited InitWidget;
  {$ENDIF VisualCLX}
  {$IFDEF NeedSetLayer}
  InitProcs;
  if HandleAllocated and Assigned(DynamicSetLayeredWindowAttributes) then
  begin
    {$IFDEF VCL}
    Wnd := Handle;
    {$ENDIF VCL}
    {$IFDEF VisualCLX}
    Wnd := QWidget_winId(Handle);
    //SetWindowLong(h, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
    //SetWindowLong(h, GWL_STYLE, WS_POPUP);
    {$ENDIF VisualCLX}
    SetWindowLong(Wnd, GWL_EXSTYLE, GetWindowLong(Wnd, GWL_EXSTYLE) or WS_EX_LAYERED);
    DynamicSetLayeredWindowAttributes(Wnd, 0, cShadowAlpha, LWA_ALPHA);
  end;
  {$ENDIF NeedSetLayer}
end;

{$IFDEF VCL}

procedure TShadowWindow.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := WS_POPUP;
    ExStyle := WS_EX_TOOLWINDOW;
  end;
end;

procedure TShadowWindow.WMNCHitTest(var Msg: TWMNCHitTest);
begin
  Msg.Result := HTTRANSPARENT;
end;

{$ENDIF VCL}

{$IFDEF VisualCLX}
function TShadowWindow.WidgetFlags: Integer;
begin
  Result :=
    Integer(WidgetFlags_WType_Popup) or         // WS_POPUPWINDOW
    Integer(WidgetFlags_WStyle_NoBorder) or
    Integer(WidgetFlags_WStyle_Tool);           // WS_EX_TOOLWINDOW
end;
{$ENDIF VisualCLX}

procedure TShadowWindow.VisibleChanged;
begin
  inherited VisibleChanged;
  // make sure shadow is beneath zoom panel
  if Visible and (Parent <> nil) then
    SetWindowPos(Handle, TWinControl(Owner).Handle, 0, 0, 0, 0,
      SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_NOOWNERZORDER);
end;

{$ENDIF MSWINDOWS}

//=== { TJvCustomCharMap } ===================================================

constructor TJvCustomCharMap.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  DoubleBuffered := True;
  //  DefaultDrawing := False;
  //  VirtualView := True;

  FCharRange := TJvCharMapRange.Create;
  //  FCharRange.Filter := ufUndefined;
  //  FCharRange.SetRange($21, $FF);
  FCharRange.OnChange := DoRangeChange;
  FCharPanel := TCharZoomPanel.Create(Self);
  FCharPanel.Visible := False;
  FCharPanel.Parent := Self;

  Options := [goVertLine, goHorzLine, {goDrawFocusSelected, } goThumbTracking];
  FShowZoomPanel := True;
  DefaultRowHeight := Abs(Font.Height) + 12;
  DefaultColWidth := DefaultRowHeight - 5;
  {$IFDEF VCL}
  FLocale := LOCALE_USER_DEFAULT;
  {$ENDIF VCL}
  FShowShadow := True;
  FShadowSize := 2;
  FHighlightInvalid := True;
  Columns := 20;
end;

destructor TJvCustomCharMap.Destroy;
begin
  FCharRange.Free;
  inherited Destroy;
end;

procedure TJvCustomCharMap.AdjustSize;
var
  AWidth, AHeight: Integer;
begin
  if HandleAllocated and (ColCount > 0) and (RowCount > 0) then
  begin
    AWidth := DefaultColWidth * (ColCount) + ColCount;
    AHeight := DefaultRowHeight * (RowCount) + RowCount;
    if AutoSizeWidth and (ClientWidth <> AWidth) and
       (Align in [alNone, alLeft, alRight]) then
      ClientWidth := AWidth;
    if AutoSizeHeight and (ClientHeight <> AHeight) and
       (Align in [alNone, alTop, alBottom]) then
      ClientHeight := AHeight;
  end;
end;

function TJvCustomCharMap.CellSize: TSize;
begin
  Result.cx := DefaultColWidth;
  Result.cy := DefaultRowHeight;
end;

procedure TJvCustomCharMap.FontChanged;
begin
  inherited FontChanged;
  if AutoSize then
    AdjustSize;
  RecalcCells;
end;

{$IFDEF VCL}
procedure TJvCustomCharMap.CreateHandle;
begin
  inherited CreateHandle;
  RecalcCells;
end;
{$ENDIF VCL}

{$IFDEF VisualCLX}
procedure TJvCustomCharMap.CreateWidget;
begin
  inherited CreateWidget;
  RecalcCells;
end;
{$ENDIF VisualCLX}

function TJvCustomCharMap.DoMouseWheelDown(Shift: TShiftState;
  {$IFDEF VisualCLX} const {$ENDIF} MousePos: TPoint): Boolean;
begin
  // ignore the return value, because inherited always returns True
  inherited DoMouseWheelDown(Shift, MousePos);
  Result := PanelVisible and SelectCell(Col, Row);
  if Result then
    ShowCharPanel(Col, Row);
  Result := True;
end;

function TJvCustomCharMap.DoMouseWheelUp(Shift: TShiftState;
  {$IFDEF VisualCLX} const {$ENDIF} MousePos: TPoint): Boolean;
begin
  // ignore the return value, because inherited always returns True
  inherited DoMouseWheelUp(Shift, MousePos);
  Result := PanelVisible and SelectCell(Col, Row);
  if Result then
    ShowCharPanel(Col, Row);
  Result := True;
end;

procedure TJvCustomCharMap.DoRangeChange(Sender: TObject);
begin
  TCharZoomPanel(FCharPanel).FEndChar := CharRange.EndChar;
  RecalcCells;
end;

procedure TJvCustomCharMap.DoSelectChar(AChar: WideChar);
begin
  if Assigned(FOnSelectChar) then
    FOnSelectChar(Self, AChar);
end;

procedure TJvCustomCharMap.DrawCell(ACol, ARow: Integer; ARect: TRect;
  AState: TGridDrawState);
var
  AChar: WideChar;
  LineColor: TColor;
begin
  if FDrawing then
    Exit;
  FDrawing := True;
  try
    {$IFDEF COMPILER6_UP}
    inherited DrawCell(ACol, ARow, ARect, AState);
    {$ENDIF COMPILER6_UP}
    AChar := GetChar(ACol, ARow);
    Canvas.Brush.Color := Color;
    Canvas.Font := Font;
    Canvas.Pen.Color := Font.Color;
    if SelectCell(ACol, ARow) and IsValidChar(AChar) then
    begin
      if AState * [gdSelected, gdFocused] <> [] then
      begin
        Canvas.Pen.Color := Font.Color;
        if not ShowZoomPanel then
        begin
          Canvas.Brush.Color := clHighlight;
          Canvas.FillRect(ARect);
        end;
        InflateRect(ARect, -1, -1);
        Canvas.Rectangle(ARect);
        InflateRect(ARect, 1, 1);
      end
      else
        Canvas.FillRect(ARect);
      if not ShowZoomPanel and (AState * [gdSelected, gdFocused] <> []) then
        Canvas.Font.Color := clHighlightText;
      SetBkMode(Canvas.Handle, Windows.TRANSPARENT);
      WideDrawText(Canvas, AChar, ARect,
        DT_SINGLELINE or DT_CENTER or DT_VCENTER or DT_NOPREFIX);
    end
    else
    if HighlightInvalid then
    begin
      LineColor := clSilver;
      if ColorToRGB(Color) = clSilver then
        LineColor := clGray;
      Canvas.Pen.Color := Color;
      Canvas.Brush.Color := LineColor;
      Canvas.Brush.Style := bsBDiagonal;
      // InflateRect(ARect,1,1);
      Canvas.Rectangle(ARect);
      Canvas.Brush.Style := bsSolid;
    end;
    finally
      FDrawing := False;
    end;
end;

function TJvCustomCharMap.GetChar(ACol, ARow: Integer): WideChar;
begin
  if (ARow < 0) or (ACol < 0) then
    Result := WideChar(0)
  else
    Result := WideChar(CharRange.StartChar +
      Cardinal(ARow) * Cardinal(ColCount) + Cardinal(ACol));
end;

function TJvCustomCharMap.GetCharacter: WideChar;
begin
  Result := GetChar(Col, Row);
end;

function TJvCustomCharMap.GetCharInfo(ACol, ARow: Integer;
  InfoType: Cardinal): Cardinal;
begin
  Result := GetCharInfo(GetChar(ACol, ARow), InfoType);
end;

function TJvCustomCharMap.GetCharInfo(AChar: WideChar;
  InfoType: Cardinal): Cardinal;
var
  LCharInfo: Cardinal;
begin
  LCharInfo := 0;
  {$IFDEF VCL}
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    // Locale is ignored on NT platforms
    if GetStringTypeExW(0, InfoType, @AChar, 1, LCharInfo) then
      Result := LCharInfo
    else
      Result := 0;
  end
  else
  begin
    if GetStringTypeEx(Locale, InfoType, @AChar, 1, LCharInfo) then
      Result := LCharInfo
    else
      Result := 0;
  end;
  {$ENDIF VCL}
  {$IFDEF VisualCLX}
  {TODO : implement this if possible}
  Result := LCharInfo;
  {$ENDIF VisualCLX}
end;

function TJvCustomCharMap.GetColumns: Integer;
begin
  Result := ColCount;
end;

function TJvCustomCharMap.GetPanelVisible: Boolean;
begin
  if (FCharPanel <> nil) and (Parent <> nil) and
     not (csDesigning in ComponentState) then
    Result := FCharPanel.Visible
  else
    Result := False;
end;

function TJvCustomCharMap.IsValidChar(AChar: WideChar): Boolean;
var
  LCharInfo: Cardinal;
begin
  Result := False;
  if (AChar >= WideChar(CharRange.StartChar)) and
    (AChar <= WideChar(CharRange.EndChar)) then
  begin
    LCharInfo := GetCharInfo(AChar, CT_CTYPE1);
    Result := (LCharInfo <> 0); //  and (LCharInfo and C1_CNTRL <> C1_CNTRL);
  end;

  if Assigned(FOnValidateChar) then
    FOnValidateChar(Self, AChar, Result);
end;

procedure TJvCustomCharMap.KeyDown(var Key: Word; Shift: TShiftState);
var
  ACol, ARow: Integer;
begin
  // store previous location
  ACol := Col;
  ARow := Row;
  // update new location
  inherited KeyDown(Key, Shift);
  // (rom) only accept without Shift, Alt or Ctrl down
  if Shift * KeyboardShiftStates = [] then
    case Key of
      VK_RETURN:
        ShowCharPanel(Col, Row);