home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d123456 / DFS.ZIP / ElpsPanl.pas < prev    next >
Pascal/Delphi Source File  |  2001-06-27  |  17KB  |  478 lines
  1. {$I DFS.INC}  { Standard defines for all Delphi Free Stuff components }
  2.  
  3. {------------------------------------------------------------------------------}
  4. { TdfsEllipsisPanel v1.19                                                      }
  5. {------------------------------------------------------------------------------}
  6. { A panel that can shorten the caption text, replacing it with '...' when      }
  7. { it does not fit the available space.  Also provided is a generic function    }
  8. { that will "ellipsify" a string.  This function can be used to produce        }
  9. { other components like TdfsEllipsisPanel, such as TdfsEllipsisLabel.          }
  10. {                                                                              }
  11. { Copyright 2000-2001, Brad Stowers.  All Rights Reserved.                     }
  12. {                                                                              }
  13. { Copyright:                                                                   }
  14. { All Delphi Free Stuff (hereafter "DFS") source code is copyrighted by        }
  15. { Bradley D. Stowers (hereafter "author"), and shall remain the exclusive      }
  16. { property of the author.                                                      }
  17. {                                                                              }
  18. { Distribution Rights:                                                         }
  19. { You are granted a non-exlusive, royalty-free right to produce and distribute }
  20. { compiled binary files (executables, DLLs, etc.) that are built with any of   }
  21. { the DFS source code unless specifically stated otherwise.                    }
  22. { You are further granted permission to redistribute any of the DFS source     }
  23. { code in source code form, provided that the original archive as found on the }
  24. { DFS web site (http://www.delphifreestuff.com) is distributed unmodified. For }
  25. { example, if you create a descendant of TDFSColorButton, you must include in  }
  26. { the distribution package the colorbtn.zip file in the exact form that you    }
  27. { downloaded it from http://www.delphifreestuff.com/mine/files/colorbtn.zip.   }
  28. {                                                                              }
  29. { Restrictions:                                                                }
  30. { Without the express written consent of the author, you may not:              }
  31. {   * Distribute modified versions of any DFS source code by itself. You must  }
  32. {     include the original archive as you found it at the DFS site.            }
  33. {   * Sell or lease any portion of DFS source code. You are, of course, free   }
  34. {     to sell any of your own original code that works with, enhances, etc.    }
  35. {     DFS source code.                                                         }
  36. {   * Distribute DFS source code for profit.                                   }
  37. {                                                                              }
  38. { Warranty:                                                                    }
  39. { There is absolutely no warranty of any kind whatsoever with any of the DFS   }
  40. { source code (hereafter "software"). The software is provided to you "AS-IS", }
  41. { and all risks and losses associated with it's use are assumed by you. In no  }
  42. { event shall the author of the softare, Bradley D. Stowers, be held           }
  43. { accountable for any damages or losses that may occur from use or misuse of   }
  44. { the software.                                                                }
  45. {                                                                              }
  46. { Support:                                                                     }
  47. { Support is provided via the DFS Support Forum, which is a web-based message  }
  48. { system.  You can find it at http://www.delphifreestuff.com/discus/           }
  49. { All DFS source code is provided free of charge. As such, I can not guarantee }
  50. { any support whatsoever. While I do try to answer all questions that I        }
  51. { receive, and address all problems that are reported to me, you must          }
  52. { understand that I simply can not guarantee that this will always be so.      }
  53. {                                                                              }
  54. { Clarifications:                                                              }
  55. { If you need any further information, please feel free to contact me directly.}
  56. { This agreement can be found online at my site in the "Miscellaneous" section.}
  57. {------------------------------------------------------------------------------}
  58. { The lateset version of my components are always available on the web at:     }
  59. {   http://www.delphifreestuff.com/                                            }
  60. { See ElpsPanl.txt for notes, known issues, and revision history.              }
  61. {------------------------------------------------------------------------------}
  62. { Date last modified:  June 27, 2001                                           }
  63. {------------------------------------------------------------------------------}
  64.  
  65. unit ElpsPanl;
  66.  
  67. interface
  68.  
  69. uses
  70.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  71.   Forms, Dialogs, ExtCtrls, Menus;
  72.  
  73. const
  74.   { This shuts up C++Builder 3 about the redefiniton being different. There
  75.     seems to be no equivalent in C1.  Sorry. }
  76.   {$IFDEF DFS_CPPB_3_UP}
  77.   {$EXTERNALSYM DFS_COMPONENT_VERSION}
  78.   {$ENDIF}
  79.   DFS_COMPONENT_VERSION = 'TdfsEllipsisPanel v1.19';
  80.  
  81. type
  82.   TAutoHintOption = (ahEnabled, ahWindowOnly, ahOnEllipsis);
  83.   { ahEnabled    - Enable auto hint (set hint when caption too big.           }
  84.   { ahWindowOnly - Don't generate applicatoin events, only the popup hint.    }
  85.   {                Basically, it sticks an '|' on the end of the hint string. }
  86.   { ahOnEllipsis - When Caption too big, Hint is set to Caption. When Caption }
  87.   {                fits, Hint is set to last value assigned to it, either in  }
  88.   {                IDE or code. For example, you set Hint = "My hint" and the }
  89.   {                panel has to use "..." when it displayes the caption       }
  90.   {                "Some Text String".  The hint would pop up as "Some Text   }
  91.   {                String".  You then resize and the entire caption can be    }
  92.   {                displayed in the panel.  The hint would then be "My hint". }
  93.  
  94.   TAutoHintOptions = set of TAutoHintOption;
  95.  
  96. const
  97.   DEF_AUTOHINTOPTIONS = [ahEnabled, ahWindowOnly, ahOnEllipsis];
  98.  
  99. type
  100.   TdfsEllipsisPanel = class(TCustomPanel)
  101.   private
  102.     FAutoHintOptions: TAutoHintOptions;
  103.     FIsPath: boolean;
  104.     FCaption: string;
  105.     FSaveHint: string;
  106.  
  107.     procedure SetAutoHintOptions(Val: TAutoHintOptions);
  108.     procedure SetIsPath(Val: boolean);
  109.     procedure SetCaption(const Val: string);
  110.     function GetCaption: string;
  111.  
  112.     procedure WMSize(var Msg: TWMSize); message WM_SIZE;
  113.     procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;
  114.   protected
  115.     procedure UpdatePanelText;
  116.     procedure UpdateHintText;
  117.     procedure Loaded; override;
  118.     function GetVersion: string;
  119.     procedure SetVersion(const Val: string);
  120.   public
  121.     constructor Create(AOwner: TComponent); override;
  122.     {$IFDEF DFS_COMPILER_4_UP}
  123.     property DockManager;
  124.     {$ENDIF}
  125.   published
  126.     property Version: string
  127.        read GetVersion
  128.        write SetVersion
  129.        stored FALSE;
  130.     property AutoHintOptoins: TAutoHintOptions
  131.        read FAutoHintOptions
  132.        write SetAutoHintOptions
  133.        default DEF_AUTOHINTOPTIONS;
  134.     property IsPath: boolean
  135.        read FIsPath
  136.        write SetIsPath
  137.        default FALSE;
  138.     property Caption: string
  139.        read GetCaption
  140.        write SetCaption;
  141.  
  142.     { Publish inherited stuff }
  143.     property Align;
  144.     property Alignment;
  145.     property BevelInner;
  146.     property BevelOuter;
  147.     property BevelWidth;
  148.     property BorderWidth;
  149.     property BorderStyle;
  150.     property DragCursor;
  151.     property DragMode;
  152.     property Enabled;
  153.     property Color;
  154.     property Ctl3D;
  155.     property Font;
  156.     property Locked;
  157.     property ParentColor;
  158.     property ParentCtl3D;
  159.     property ParentFont;
  160.     property ParentShowHint;
  161.     property PopupMenu;
  162.     property ShowHint default TRUE;
  163.     property TabOrder;
  164.     property TabStop;
  165.     property Visible;
  166.     property OnClick;
  167.     property OnDblClick;
  168.     property OnDragDrop;
  169.     property OnDragOver;
  170.     property OnEndDrag;
  171.     property OnEnter;
  172.     property OnExit;
  173.     property OnMouseDown;
  174.     property OnMouseMove;
  175.     property OnMouseUp;
  176.     property OnResize;
  177.     {$IFDEF DFS_COMPILER_2_UP}
  178.     property OnStartDrag;
  179.     {$ENDIF}
  180.     {$IFDEF DFS_COMPILER_3_UP}
  181.     property FullRepaint;
  182.     {$ENDIF}
  183.     {$IFDEF DFS_COMPILER_4_UP}
  184.     property Anchors;
  185.     property AutoSize;
  186.     property BiDiMode;
  187.     property Constraints;
  188.     property UseDockManager default True;
  189.     property DockSite;
  190.     property DragKind;
  191.     property ParentBiDiMode;
  192.     property OnCanResize;
  193.     property OnConstrainedResize;
  194.     property OnDockDrop;
  195.     property OnDockOver;
  196.     property OnEndDock;
  197.     property OnGetSiteInfo;
  198.     property OnStartDock;
  199.     property OnUnDock;
  200.     {$ENDIF}
  201.     {$IFDEF DFS_COMPILER_5_UP}
  202.     property OnContextPopup;
  203.     {$ENDIF}
  204.     {$IFDEF DFS_COMPILER_7_UP}
  205.     Make sure to add any new properties introduced in TPanel.
  206.     {$ENDIF}
  207.   end;
  208.  
  209. function EllipsifyText(AsPath: boolean; const Text: string;
  210.                        const Canvas: TCanvas; MaxWidth: integer): string;
  211.  
  212.  
  213. implementation
  214.  
  215.  
  216. {$IFNDEF DFS_WIN32}
  217. procedure SetLength(var s: string; NewLen: byte);
  218. begin
  219.   S[0] := chr(NewLen);
  220. end;
  221. {$ENDIF}
  222.  
  223. function EllipsifyText(AsPath: boolean; const Text: string;
  224.                        const Canvas: TCanvas; MaxWidth: integer): string;
  225. {$IFDEF DFS_WIN32}
  226. var
  227.    TempPChar: PChar;
  228.    TempRect: TRect;
  229.    Params: UINT;
  230. begin
  231.   // Alocate mem for PChar
  232.   GetMem(TempPChar, Length(Text)+1);
  233.   try
  234.     // Copy Text into PChar
  235.     TempPChar := StrPCopy(TempPChar, Text);
  236.     // Create Rectangle to Store PChar
  237.     TempRect := Rect(0,0, MaxWidth, High(Integer));
  238.     // Set Params depending wether it's a path or not
  239.     if AsPath then
  240.       Params := DT_PATH_ELLIPSIS
  241.     else
  242.       Params := DT_END_ELLIPSIS;
  243.     // Tell it to Modify the PChar, and do not draw to the canvas
  244.     Params := Params + DT_MODIFYSTRING + DT_CALCRECT;
  245.     // Ellipsify the string based on availble space to draw in
  246.     DrawTextEx(Canvas.Handle, TempPChar, -1, TempRect, Params, nil);
  247.     // Copy the modified PChar into the result
  248.     Result := StrPas(TempPChar);
  249.   finally
  250.     // Free Memory from PChar
  251.     FreeMem(TempPChar, Length(Text)+1);
  252.   end;
  253. {$ELSE}
  254.   procedure CutFirstDirectory(var S: string);
  255.   var
  256.     Root: Boolean;
  257.     P: Integer;
  258.   begin
  259.     if S = '' then exit;
  260.     if S = '\' then
  261.       S := ''
  262.     else begin
  263.       if S[1] = '\' then begin
  264.         Root := True;
  265.         Delete(S, 1, 1);
  266.       end else
  267.         Root := False;
  268.       if S[1] = '.' then
  269.         Delete(S, 1, 4);
  270.       P := Pos('\',S);
  271.       if P <> 0 then begin
  272.         Delete(S, 1, P);
  273.         S := '...\' + S;
  274.       end else
  275.         S := '';
  276.       if Root then
  277.         S := '\' + S;
  278.     end;
  279.   end;
  280.  
  281.   function MinimizeName(const Filename: string; const Canvas: TCanvas;
  282.                         MaxLen: Integer): string;
  283.   var
  284.     Drive: string;
  285.     Dir: string;
  286.     Name: string;
  287.   begin
  288.     Result := FileName;
  289.     Dir := ExtractFilePath(Result);
  290.     Name := ExtractFileName(Result);
  291.  
  292.     if (Length(Dir) >= 2) and (Dir[2] = ':') then begin
  293.       Drive := Copy(Dir, 1, 2);
  294.       Delete(Dir, 1, 2);
  295.     end else
  296.       Drive := '';
  297.     while ((Dir <> '') or (Drive <> '')) and (Canvas.TextWidth(Result) > MaxLen) do begin
  298.       if Dir = '\...\' then begin
  299.         Drive := '';
  300.         Dir := '...\';
  301.       end else if Dir = '' then
  302.         Drive := ''
  303.       else
  304.         CutFirstDirectory(Dir);
  305.       Result := Drive + Dir + Name;
  306.     end;
  307.   end;
  308. var
  309.   Temp: string;
  310.   AvgChar: integer;
  311.   TLen,
  312.   Index: integer;
  313.   Metrics: TTextMetric;
  314. begin
  315.   try
  316.     if AsPath then begin
  317.       Result := MinimizeName(Text, Canvas, MaxWidth);
  318.     end else begin
  319.       Temp := Text;
  320.       if (Temp <> '') and (Canvas.TextWidth(Temp) > MaxWidth) then begin
  321.         GetTextMetrics(Canvas.Handle, Metrics);
  322.         AvgChar := Metrics.tmAveCharWidth;
  323.         if (AvgChar * 3) < MaxWidth then begin
  324.           Index := (MaxWidth div AvgChar) - 1;
  325.           Temp := Copy(Text, 1, Index);
  326.           if Canvas.TextWidth(Temp + '...') > MaxWidth then begin
  327.             repeat
  328.               dec(Index);
  329.               SetLength(Temp, Index);
  330.             until (Canvas.TextWidth(Temp + '...') < MaxWidth) or (Index < 1);
  331.             { delete chars }
  332.           end else begin
  333.             TLen := Length(Text);
  334.             repeat
  335.               inc(Index);
  336.               Temp := Copy(Text, 1, Index);
  337.             until (Canvas.TextWidth(Temp + '...') > MaxWidth) or (Index >= TLen);
  338.             SetLength(Temp, Index-1);
  339.           end;
  340.           Temp := Temp + '...';
  341.         end else
  342.           Temp := '.';
  343.       end;
  344.       Result := Temp;
  345.     end;
  346.   except
  347.     Result := '';
  348.   end;
  349. {$ENDIF}
  350. end;
  351.  
  352.  
  353. constructor TdfsEllipsisPanel.Create(AOwner: TComponent);
  354. begin
  355.   inherited Create(AOwner);
  356.   FAutoHintOptions := DEF_AUTOHINTOPTIONS;
  357.   ShowHint := TRUE;
  358.   FIsPath := FALSE;
  359.   FCaption := '';
  360.   FSaveHint := '';
  361. end;
  362.  
  363. procedure TdfsEllipsisPanel.Loaded;
  364. begin
  365.   inherited Loaded;
  366.   FSaveHint := Hint;
  367. end;
  368.  
  369. procedure TdfsEllipsisPanel.UpdatePanelText;
  370. begin
  371.   if HandleAllocated then begin
  372.     { Make sure the right font has been selected. }
  373.     Canvas.Font.Assign(Font);
  374.     inherited Caption := EllipsifyText(FIsPath, FCaption, Canvas,
  375.        ClientWidth-(BevelWidth*2)-BorderWidth*2);
  376.     UpdateHintText;
  377.   end;
  378. end;
  379.  
  380. procedure TdfsEllipsisPanel.UpdateHintText;
  381.   function LastChar(const Str: string): char;
  382.   begin
  383.     if Length(Str) > 0 then
  384.       Result := Str[Length(Str)]
  385.     else
  386.       Result := #0;
  387.   end;
  388. begin
  389.   if ahEnabled in FAutoHintOptions then begin
  390.     if ahOnEllipsis in FAutoHintOptions then begin
  391.       if (Length(inherited Caption) > 2) and
  392.          (Copy(inherited Caption, Length(inherited Caption)-2, 3) = '...') then
  393.         Hint := FCaption
  394.       else
  395.         Hint := FSaveHint;
  396.     end else
  397.       Hint := FCaption;
  398.  
  399. {.$DEFINE WANT-TO-SEE-A-DELPHI-2-BUG}
  400. {$IFDEF WANT-TO-SEE-A-DELPHI-2-BUG}
  401.     if ahWindowOnly in FAutoHintOptions then begin
  402. (* This code causes internal error c3254!  It is the second part of the "if" statement,
  403.    but only if there is some code inside the begin...end.
  404.                                 vvvvvvvvvvvvvvvvvvvvvvvvvvv               *)
  405.       if (Length(Hint) > 0) and (Hint[Length(Hint)] <> '|') then
  406.         Hint := Hint + '|';
  407.     end else begin
  408.       if (Length(Hint) > 0) and (Hint[Length(Hint)] = '|') then
  409.         Hint := Copy(Hint, 1, Length(Hint)-1);
  410.     end;
  411. {$ELSE}
  412.     if ahWindowOnly in FAutoHintOptions then begin
  413.       if LastChar(Hint) <> '|' then
  414.         Hint := Hint + '|';
  415.     end else begin
  416.       if LastChar(Hint) = '|' then
  417.         Hint := Copy(Hint, 1, Length(Hint)-1);
  418.     end;
  419. {$ENDIF}
  420.  
  421.   end else begin
  422.     Hint := FSaveHint;
  423.   end;
  424. end; { This is where you will see the C3254 error message.  Caused on line 290 }
  425.  
  426. procedure TdfsEllipsisPanel.SetAutoHintOptions(Val: TAutoHintOptions);
  427. begin
  428.   if FAutoHintOptions <> Val then begin
  429.     FAutoHintOptions := Val;
  430.     UpdateHintText;
  431.   end;
  432. end;
  433.  
  434. procedure TdfsEllipsisPanel.SetIsPath(Val: boolean);
  435. begin
  436.   if Val = FIsPath then exit;
  437.   FIsPath := Val;
  438.   UpdatePanelText;
  439. end;
  440.  
  441. procedure TdfsEllipsisPanel.SetCaption(const Val: string);
  442. begin
  443.   if Val = FCaption then exit;
  444.   FCaption := Val;
  445.   UpdatePanelText;
  446. end;
  447.  
  448. function TdfsEllipsisPanel.GetCaption: string;
  449. begin
  450.   Result := FCaption;
  451. end;
  452.  
  453. procedure TdfsEllipsisPanel.WMSize(var Msg: TWMSize);
  454. begin
  455.   inherited;
  456.   UpdatePanelText;
  457. end;
  458.  
  459. procedure TdfsEllipsisPanel.CMFontChanged(var Msg: TMessage);
  460. begin
  461.   inherited;
  462.   Refresh;
  463.   UpdatePanelText;
  464. end;
  465.  
  466. function TdfsEllipsisPanel.GetVersion: string;
  467. begin
  468.   Result := DFS_COMPONENT_VERSION;
  469. end;
  470.  
  471. procedure TdfsEllipsisPanel.SetVersion(const Val: string);
  472. begin
  473.   { empty write method, just needed to get it to show up in Object Inspector }
  474. end;
  475.  
  476. end.
  477.  
  478.