paweld/lazarus-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

tvplanit: Fix compilation with laz < 1.6 and fpc < 3.0. Refactor NavBar painting.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4986 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz 2016-07-17 10:17:24 +00:00
parent 2d689d3568
commit c3e096135d
6 changed files with 138 additions and 134 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
components/tvplanit/examples/fulldemo/demomain.lfm
View File

@ -9,7 +9,7 @@ object MainForm: TMainForm
Menu = MainMenu1
OnCloseQuery = FormCloseQuery
OnCreate = FormCreate
LCLVersion = '1.7'
LCLVersion = '1.4.4.0'
object Panel1: TPanel
Left = 120
Height = 580

18
components/tvplanit/examples/fulldemo/demomain.pas
View File

@ -138,10 +138,17 @@ uses
{$IFDEF WINDOWS}
Windows,
{$ENDIF}
LResources, LazFileUtils, LazUTF8, StrUtils, DateUtils, Translations,
LCLVersion, LResources, LazFileUtils, LazUTF8, StrUtils, DateUtils, Translations,
IniFiles, Math, Printers,
VpMisc, VpBase, VpPrtFmt;
{$UNDEF UTF8_CALLS}
{$IFDEF LCL}
{$IF lcl_fullversion >= 3000000}
{$DEFINE UTF8_CALLS}
{$ENDIF}
{$ENDIF}
const
LANGUAGE_DIR = '..\..\languages\';
@ -223,7 +230,11 @@ begin
LCID := LangToLCID(ALang);
// Now we update the format settings to the new language
{$IFDEF UTF8_CALLS}
GetLocaleFormatSettingsUTF8(LCID, DefaultFormatSettings);
{$ELSE}
GetLocaleFormatSettings(LCID, DefaultFormatSettings);
{$ENDIF}
{$ENDIF}
end;
@ -484,7 +495,8 @@ begin
end;
CbLanguages.Items.Assign(po);
SetLanguage(GetDefaultLang);
SetLanguage(lang);
// SetLanguage(GetDefaultLang);
finally
po.Free;
@ -566,7 +578,7 @@ begin
if h < 160 then h := 160;
VpMonthView1.Height := h;
lang := ini.ReadString('Settings', 'Language', GetDefaultLang);
lang := ini.ReadString('Settings', 'Language', ''); //GetDefaultLang);
SetLanguage(lang);
SetActiveView(ini.ReadInteger('Settings', 'ActiveView', 0));

6
components/tvplanit/source/laz_visualplanit.lpk
View File

@ -30,7 +30,7 @@ Portions created by TurboPower Software Inc. are Copyright (C) 2002 TurboPower S
Contributor(s): "/>
<Version Major="1" Release="4"/>
<Files Count="74">
<Files Count="75">
<Item1>
<Filename Value="vpalarmdlg.lfm"/>
<Type Value="LFM"/>
@ -328,6 +328,10 @@ Contributor(s): "/>
<Filename Value="vpxmlds.pas"/>
<UnitName Value="VpXmlDs"/>
</Item74>
<Item75>
<Filename Value="vpnavbarpainter.pas"/>
<UnitName Value="VpNavBarPainter"/>
</Item75>
</Files>
<i18n>
<EnableI18N Value="True"/>

62
components/tvplanit/source/vpevnteditdlg.pas
View File

@ -35,7 +35,7 @@ interface
uses
{$IFDEF LCL}
LCLProc, LCLType, LCLIntf, LResources, EditBtn,
LCLProc, LCLType, LCLIntf, LResources, LCLVersion, EditBtn,
{$ELSE}
Windows, Messages, Mask,
{$ENDIF}
@ -43,6 +43,15 @@ uses
Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, ComCtrls, Buttons,
VpData, VpBase, VpBaseDS, VpDlg, VpConst; //VpEdPop,
const
blabla = 1; // to make the $IF work in Laz 1.4.4. Why?
{$UNDEF NEW_TIME_EDIT}
{$IFDEF LCL}
{$IF lcl_fullversion >= 3000000}
{$DEFINE NEW_TIME_EDIT}
{$ENDIF}
{$ENDIF}
type
{ forward declarations }
TVpEventEditDialog = class;
@ -114,13 +123,12 @@ type
procedure FormShow(Sender: TObject);
private { Private declarations }
{$IFDEF LCL}
{$IFDEF NEW_TIME_EDIT}
StartTime: TTimeEdit;
EndTime: TTimeEdit;
{$ENDIF}
{$IFDEF DELPHI}
StartTime: TComboBox;
EndTime: TComboBox;
{$ELSE}
StartTime: TCombobox;
EndTime: TCombobox;
{$ENDIF}
FDatastore: TVpCustomDatastore;
AAVerifying: Boolean;
@ -168,7 +176,7 @@ type
implementation
uses
Math,
Math, DateUtils,
VpSR, VpMisc, VpWavDlg;
{$IFDEF LCL}
@ -202,11 +210,11 @@ end;
procedure TDlgEventEdit.FormCreate(Sender: TObject);
begin
{$IFDEF LCL}
{$IFDEF NEW_TIME_EDIT}
StartTime := TTimeEdit.Create(self);
{$ELSE}
StartTime := TCombobox.Create(self);
StartTime.Width := 93;
StartTime.Width := 83;
StartTime.ItemIndex := -1;
{$ENDIF}
StartTime.Parent := AppointmentGroupbox;
@ -214,7 +222,7 @@ begin
StartTime.Top := StartDate.Top;
StartTime.TabOrder:= StartDate.TabOrder+ 1;
{$IFDEF LCL}
{$IFDEF NEW_TIME_EDIT}
EndTime := TTimeEdit.Create(self);
{$ELSE}
EndTime := TCombobox.Create(self);
@ -255,17 +263,27 @@ var
res: Integer;
tStart, tEnd: TDateTime;
begin
{$IFDEF NEW_TIME_EDIT}
tStart := trunc(StartDate.Date) + frac(StartTime.Time);
tEnd := trunc(EndDate.Date) + frac(EndTime.Time);
{$ELSE}
tStart := trunc(StartDate.Date) + StrToTime(StartTime.Text);
tEnd := trunc(EndDate.Date) + StrToTime(EndTime.Text);
{$ENDIF}
if (tStart > tEnd) then begin
res := MessageDlg(RSStartEndTimeError,
mtConfirmation, [mbYes, mbNo], 0);
if res = mrYes then begin
StartDate.Date := trunc(tEnd);
StartTime.Time := frac(tEnd);
EndDate.Date := trunc(tStart);
EndTime.Time := frac(tStart);
{$IFDEF NEW_TIME_EDIT}
StartTime.Time := TimeOf(tEnd);
EndTime.Time := timeOf(tStart);
{$ELSE}
StartTime.Text := FormatDateTime('hh:nn', TimeOf(tEnd));
EndTime.Text := FormatDateTime('hh:nn', TimeOf(tStart));
{$ENDIF}
end else
exit;
end;
@ -323,13 +341,13 @@ begin
StartDate.Date := trunc(Event.StartTime);
EndDate.Date := trunc(Event.EndTime);
RepeatUntil.Date := trunc(Event.RepeatRangeEnd);
{$IFDEF LCL}
{$IFDEF NEW_TIME_EDIT}
StartTime.Time := frac(Event.StartTime);
EndTime.Time := frac(Event.EndTime);
{$ELSE}
StartTime.Text := FormatDateTime('hh:nn',Event.StartTime);
EndTime.Text := FormatDateTime('hh:nn',Event.EndTime);
{$ENDIF}
{$ELSE}
StartTime.Text := FormatDateTime('hh:nn', Event.StartTime);
EndTime.Text := FormatDateTime('hh:nn', Event.EndTime);
{$ENDIF}
CBAllDay.Checked := Event.AllDayEvent;
AlarmWavPath := Event.DingPath;
@ -367,13 +385,13 @@ end;
procedure TDlgEventEdit.DePopulateDialog;
begin
{ Events }
{$IFDEF LCL}
{$IFDEF NEW_TIME_EDIT}
Event.StartTime := StartDate.Date + StartTime.Time;
Event.EndTime := EndDate.Date + EndTime.Time;
{$ELSE}
{$ELSE}
Event.StartTime := StartDate.Date + StrToTime(StartTime.Text);
Event.EndTime := EndDate.Date + StrToTime(EndTime.Text);
{$ENDIF}
{$ENDIF}
Event.RepeatRangeEnd := RepeatUntil.Date;
Event.Description := DescriptionEdit.Text;
Event.Location := LocationEdit.Text;
@ -389,14 +407,14 @@ begin
end;
procedure TDlgEventEdit.PopLists;
{$IFDEF DELPHI}
{$IFNDEF NEW_TIME_EDIT}
var
StringList: TStringList;
I, Hour, Minute: Integer;
MinStr, AMPMStr: string;
{$ENDIF}
begin
{$IFDEF DELPHI} // No longer needed for Lazarus using a TTimeEdit now.
{$IFNDEF NEW_TIME_EDIT} // No longer needed for Lazarus using a TTimeEdit now.
{ Time Lists }
StringList := TStringList.Create;
try

155
components/tvplanit/source/vpnavbar.pas
View File

@ -28,6 +28,8 @@
{$I vp.inc}
{$DEFINE PAINTER}
unit VpNavBar;
interface
@ -85,8 +87,9 @@ type
destructor Destroy; override;
property Folder: TVpNavFolder read FFolder;
procedure Assign(Source: TPersistent); override;
property IconRect: TRect read FIconRect;
property LabelRect: TRect read FLabelRect;
property DisplayName: String read liDisplayName write liDisplayName; // wp: needed by painter
property IconRect: TRect read FIconRect write FIconRect; // wp: Setter needed by painter
property LabelRect: TRect read FLabelRect write FLabelRect; // wp: Setter needed by painter
published
property Caption: string read FCaption write SetCaption;
property Description: string read FDescription write FDescription;
@ -133,6 +136,8 @@ type
property Items[Index: Integer]: TVpNavBtnItem read GetItem;
property ItemCount: Integer read GetItemCount;
property ContainerIndex: Integer read FContainerIndex write FContainerIndex;
property DisplayName: String read lfDisplayName; // made public for painter
property Rect: TRect read lfRect write lfRect; // made public for painter
published
property Caption: string read FCaption write SetCaption;
@ -448,6 +453,10 @@ type
implementation
uses
Themes,
VpNavBarPainter;
{DrawNavTab - returns the usable text area inside the tab rect.}
function DrawNavTab(Canvas: TCanvas; const Client: TRect; BevelWidth: Integer;
TabColor: TColor; TabNumber: Integer; CoolTab, IsFocused, IsMouseOver: Boolean): TRect;
@ -1455,91 +1464,6 @@ begin
end;
{=====}
{ Given a string, and a rectangle, find the string that can be displayed
using two lines. Add ellipsis to the end of each line if necessary and
possible}
function GetLargeIconDisplayName(Canvas: TCanvas; Rect: TRect;
const Name: string): string;
var
TestRect: TRect;
SH, DH: Integer;
Buf: array[0..255] of Char;
I: Integer;
TempName: string;
Temp2: string;
begin
TempName := Trim(Name);
{get single line height}
with TestRect do begin
Left := 0;
Top := 0;
Right := 1;
Bottom := 1;
end;
SH := DrawText(Canvas.Handle, 'W W', 3, TestRect, DT_SINGLELINE or DT_CALCRECT);
{get double line height}
with TestRect do begin
Left := 0;
Top := 0;
Right := 1;
Bottom := 1;
end;
DH := DrawText(Canvas.Handle, 'W W', 3, TestRect, DT_WORDBREAK or DT_CALCRECT);
{see if the text can fit within the existing rect without growing}
TestRect := Rect;
StrPLCopy(Buf, TempName, 255);
DrawText(Canvas.Handle, Buf, Length(TempName), TestRect, DT_WORDBREAK or DT_CALCRECT);
I := Pos(' ', TempName);
if (RectHeight(TestRect) = SH) or (I < 2) then
Result := GetDisplayString(Canvas, TempName, 1, RectWidth(Rect))
else begin
{the first line only has ellipsis if there's only one word on it and
that word won't fit}
Temp2 := GetDisplayString(Canvas, Copy(TempName, 1, I-1), 1, RectWidth(Rect));
if CompareStr(Temp2, Copy(TempName, 1, I-1)) <> 0 then begin
Result := GetDisplayString(Canvas, Copy(TempName, 1, I-1), 1, RectWidth(Rect)) + ' ' +
GetDisplayString(Canvas, Copy(TempName, I+1, Length(TempName) - I), 1, RectWidth(Rect));
end else begin
{2 or more lines, and the first line isn't getting an ellipsis}
if (RectHeight(TestRect) = DH) and (RectWidth(TestRect) <= RectWidth(Rect)) then
{it will fit}
Result := TempName
else begin
{it won't fit, but the first line wraps OK - 2nd line needs an ellipsis}
TestRect.Right := Rect.Right + 1;
while (RectWidth(TestRect) > RectWidth(Rect)) or (RectHeight(TestRect) > DH) do
begin
if Length(TempName) > 1 then begin
TestRect := Rect;
Delete(TempName, Length(TempName), 1);
TempName := Trim(TempName);
StrPLCopy(Buf, TempName + '...', 255);
DrawText(Canvas.Handle, Buf, Length(TempName) + 3, TestRect, DT_WORDBREAK or DT_CALCRECT);
Result := TempName + '...';
end else begin
Result := TempName + '..';
TestRect := Rect;
StrPLCopy(Buf, Result, 255);
DrawText(Canvas.Handle, Buf, Length(Result), TestRect, DT_WORDBREAK or DT_CALCRECT);
if (RectWidth(TestRect) <= RectWidth(Rect)) and (RectHeight(TestRect) > DH) then
Break;
Result := TempName + '.';
TestRect := Rect;
StrPLCopy(Buf, Result, 255);
DrawText(Canvas.Handle, Buf, Length(Result), TestRect, DT_WORDBREAK or DT_CALCRECT);
if (RectWidth(TestRect) <= RectWidth(Rect)) and (RectHeight(TestRect) > DH) then
Break;
Result := TempName;
end;
end;
end;
end;
end;
end;
{=====}
function TVpCustomNavBar.nabButtonRect(Index: Integer): TRect;
begin
Result := Folders[Index].lfRect;
@ -2054,6 +1978,20 @@ begin
end;
{=====}
{$IFDEF PAINTER}
procedure TVpCustomNavBar.Paint;
var
painter: TVpNavBarPainter;
begin
painter := TVpNavBarPainter.Create(Self);
try
painter.Paint;
finally
painter.Free;
end;
end;
{$ELSE}
procedure TVpCustomNavBar.Paint;
var
I, J: Integer;
@ -2080,6 +2018,8 @@ var
ILeft: Integer;
IHeight: Integer;
IWidth: integer;
Details: TThemedElementDetails;
TB: TThemedButton;
begin
if nabChanging then
Exit;
@ -2147,7 +2087,21 @@ begin
case FDrawingStyle of
dsDefButton:
begin
{Draw regular buttons}
{Draw regular buttons}
if ThemeServices.ThemesEnabled then begin
if (I = nabLastMouseOverItem) then
TB := tbPushButtonHot
else
if (I = FHotFolder) and nabMouseDown then
TB := tbPushButtonPressed
else
TB := tbPushButtonNormal;
Details := ThemeServices.GetElementDetails(TB);
ThemeServices.DrawElement(Handle, details, MyRect);
TR := MyRect;
InflateRect(TR, -1, -1);
if I = FHotFolder then OffsetRect(TR, -1, -1); // Focused
end;
//TODO: TR := DrawButtonFace(DrawBmp.Canvas, MyRect, 1, bsNew, False,
// (I = FHotFolder) and nabMouseDown, False);
end;
@ -2499,11 +2453,27 @@ begin
MyRect.Bottom := CurPos + FButtonHeight;
Folders[I].lfRect := MyRect;
case FDrawingStyle of
dsDefButton : begin
{Regular Old Buttons}
//TODO: TR := DrawButtonFace(DrawBmp.Canvas, MyRect, 1, bsNew, False,
dsDefButton :
begin
{Regular Old Buttons}
if ThemeServices.ThemesEnabled then begin
if (I = nabLastMouseOverItem) then
TB := tbPushButtonHot
else
if (I = FHotFolder) and nabMouseDown then
TB := tbPushButtonPressed
else
TB := tbPushButtonNormal;
Details := ThemeServices.GetElementDetails(TB);
ThemeServices.DrawElement(Handle, details, MyRect);
TR := MyRect;
InflateRect(TR, -1, -1);
if I = FHotFolder then OffsetRect(TR, -1, -1); // Focused
end;
//TODO: TR := DrawButtonFace(DrawBmp.Canvas, MyRect, 1, bsNew, False,
// (I = FHotFolder) and nabMouseDown, False);
end;
end;
dsEtchedButton :
begin
@ -2683,6 +2653,7 @@ begin
Controls[i].Invalidate;
end;
end;
{$ENDIF}
{=====}
procedure TVpCustomNavBar.SetActiveFolder(Value: Integer);

29
components/tvplanit/source/vpxparsr.pas
View File

@ -301,6 +301,9 @@ implementation
{.$R *.RES}
uses
{$IFDEF FPC}
LazUtf8,
{$ENDIF}
VpMisc;
@ -989,7 +992,7 @@ begin
{$IFDEF DELPHI}
Ucs4Chr := Ucs4Chr + StrToIntDef(TempChar, 0);
{$ELSE}
Ucs4Chr := Ucs4Chr + StrToIntDef(UTF8Encode(TempChar), 0);
Ucs4Chr := Ucs4Chr + StrToIntDef(UTF16ToUTF8(TempChar), 0);
{$ENDIF}
end else
if (TempChar = ';') then
@ -998,7 +1001,7 @@ begin
{$IFDEF DELPHI}
msg := sIllCharInRef + QuotedStr(TempChar);
{$ELSE}
msg := UTF8Decode(sIllCharInRef + QuotedStr(UTF8Encode(TempChar)));
msg := UTF8Decode(sIllCharInRef + QuotedStr(UTF16ToUTF8(TempChar)));
{$ENDIF}
raise EVpParserError.CreateError(FFilter.Line, FFilter.LinePos, msg);
end;
@ -1015,7 +1018,7 @@ begin
{$IFDEF DELPHI}
Ucs4Chr := Ucs4Chr + StrToIntDef(TempChar, 0);
{$ELSE}
Ucs4Chr := Ucs4Chr + StrToIntDef(UTF8Encode(TempChar), 0);
Ucs4Chr := Ucs4Chr + StrToIntDef(UTF16ToUTF8(TempChar), 0);
{$ENDIF}
end else
if (TempChar = ';') then
@ -1024,7 +1027,7 @@ begin
{$IFDEF DELPHI}
msg := sIllCharInRef + QuotedStr(TempChar);
{$ELSE}
msg := UTF8Decode(sIllCharInRef + QuotedStr(UTF8Encode(TempChar)));
msg := UTF8Decode(sIllCharInRef + QuotedStr(UTF16ToUTF8(TempChar)));
{$ENDIF}
raise EVpParserError.CreateError(FFilter.Line, FFilter.LinePos, msg);
end;
@ -1045,9 +1048,7 @@ begin
((VpPos('--', TempComment) <> 0) or
(TempComment[Length(TempComment)] = '-')) then
{ Yes. Raise an error. }
raise EVpParserError.CreateError (FFilter.Line,
FFilter.LinePos,
sInvalidCommentText);
raise EVpParserError.CreateError(FFilter.Line, FFilter.LinePos, sInvalidCommentText);
if Assigned(FOnComment) then
FOnComment(self, TempComment);
end;
@ -1264,9 +1265,7 @@ begin
end;
SkipWhiteSpace(True);
if (not IsEndDocument) then
raise EVpParserError.CreateError (FFilter.Line,
FFilter.LinePos,
sDataAfterValDoc);
raise EVpParserError.CreateError(FFilter.Line, FFilter.LinePos, sDataAfterValDoc);
if Assigned(FOnEndDocument) then
FOnEndDocument(self);
@ -1886,7 +1885,7 @@ begin
{$IFDEF DELPHI}
EntRefs.Add('&' + DOMString(TempChar));
{$ELSE}
EntRefs.Add('&' + UTF8Encode(TempChar));
EntRefs.Add('&' + UTF16ToUTF8(TempChar));
{$ENDIF}
except
on E:EStringListError do begin
@ -1963,7 +1962,7 @@ begin
{$IFDEF DELPHI}
msg := sInvalidName + QuotedStr(TempChar);
{$ELSE}
msg := UTF8Decode(sInvalidName + QuotedStr(UTF8Encode(TempChar)));
msg := UTF8Decode(sInvalidName + QuotedStr(UTF16ToUTF8(TempChar)));
{$ENDIF}
raise EVpParserError.CreateError(FFilter.Line, FFilter.LinePos, msg);
end;
@ -1992,7 +1991,7 @@ begin
if ParseCharRef = TempStr then
Exit;
{$ELSE}
if UTF8Encode(ParseCharRef) = TempStr then
if UTF16ToUTF8(ParseCharRef) = TempStr then
Exit;
{$ENDIF}
end;
@ -2212,7 +2211,7 @@ begin
{$IFDEF DELPHI}
msg := sInvEntityValue + QuotedStr(TempChr));
{$ELSE}
msg := sInvEntityValue + QuotedStr(UTF8Encode(TempChr));
msg := sInvEntityValue + QuotedStr(UTF16ToUTF8(TempChr));
{$ENDIF}
raise EVpParserError.CreateError(FFilter.Line, FFilter.LinePos, msg);
end;
@ -2277,7 +2276,7 @@ begin
{$IFDEF DELPHI}
msg := sInvPubIDChar + QuotedStr(aString[i]);
{$ELSE}
msg := UTF8Decode(sInvPubIDChar + QuotedStr(UTF8Encode(aString[i])));
msg := UTF8Decode(sInvPubIDChar + QuotedStr(UTF16ToUTF8(aString[i])));
{$ENDIF}
raise EVpParserError.CreateError(FFilter.Line, FFilter.LinePos, msg);
end;